From 463caa5b2615947dfa75d8a77da954b19278a126 Mon Sep 17 00:00:00 2001 From: davidxl Date: Tue, 12 May 2015 16:37:45 +0000 Subject: [PATCH] Merge from trunk: 213002-213004,213007,213009-213010,213014-213017,213026-213028,213031,213034-213035,213037,213039-213040,213043,213045,213049,213054-213060,213065,213068,213071,213076-213081,213084-213085,213089-213090,213092-213093,213096-213098,213102-213103,213107-213111,213114-213118,213121,213125-213126,213134,213136,213142,213145,213150,213152-213165,213167-213170,213172-213175,213177-213183,213185,213187-213214,213216,213219-213221,213224,213227,213230,213232,213234-213250,213253-213273,213275-213311,213316-213319,213321-213342,213344-213347,213349-213383,213387,213391,213394-213401,213403,213406-213408,213410-213418,213420-213425,213427,213429-213435,213437-213454,213456-213467,213469-213471,213473-213474,213476-213491,213494-213495,213503-213505,213510-213511,213513,213515-213520,213523,213525-213526,213529-213541,213543-213573,213575-213593,213596,213598-213599 git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/google@223089 138bc75d-0d04-0410-961f-82ee72b054a4 --- main/ChangeLog | 19 + main/MAINTAINERS | 2 +- main/config.sub | 8 +- main/config/ChangeLog | 13 +- main/config/mh-alpha-linux | 3 + main/configure | 3 + main/configure.ac | 3 + main/contrib/mklog | 7 +- main/gcc/ChangeLog | 852 ++ main/gcc/DATESTAMP | 2 +- main/gcc/Makefile.in | 4 +- main/gcc/ada/ChangeLog | 4983 +++++++++++ main/gcc/ada/Make-generated.in | 50 - main/gcc/ada/Makefile.rtl | 34 +- main/gcc/ada/a-calcon.ads | 11 +- main/gcc/ada/a-calend-vms.adb | 1317 --- main/gcc/ada/a-calend-vms.ads | 310 - main/gcc/ada/a-calend.adb | 4 +- main/gcc/ada/a-cbhase.adb | 91 +- main/gcc/ada/a-cbhase.ads | 23 +- main/gcc/ada/a-cbmutr.adb | 111 +- main/gcc/ada/a-cbmutr.ads | 63 +- main/gcc/ada/a-cborse.adb | 86 +- main/gcc/ada/a-cborse.ads | 24 +- main/gcc/ada/a-cfhama.adb | 7 +- main/gcc/ada/a-cfhama.ads | 9 +- main/gcc/ada/a-cfhase.adb | 3 +- main/gcc/ada/a-cfhase.ads | 7 +- main/gcc/ada/a-cforma.adb | 3 +- main/gcc/ada/a-cforma.ads | 8 +- main/gcc/ada/a-cforse.adb | 9 +- main/gcc/ada/a-cforse.ads | 5 +- main/gcc/ada/a-chtgbo.adb | 45 +- main/gcc/ada/a-chtgbo.ads | 12 +- main/gcc/ada/a-chtgop.adb | 48 +- main/gcc/ada/a-chtgop.ads | 18 +- main/gcc/ada/a-cihase.adb | 99 +- main/gcc/ada/a-cihase.ads | 25 +- main/gcc/ada/a-ciorse.adb | 90 +- main/gcc/ada/a-ciorse.ads | 26 +- main/gcc/ada/a-cohase.adb | 104 +- main/gcc/ada/a-cohase.ads | 50 +- main/gcc/ada/a-comutr.ads | 26 +- main/gcc/ada/a-coorse.adb | 88 +- main/gcc/ada/a-coorse.ads | 26 +- main/gcc/ada/a-crdlli.ads | 6 +- main/gcc/ada/a-direct.adb | 23 +- main/gcc/ada/a-direct.ads | 20 +- main/gcc/ada/a-dirval-mingw.adb | 11 +- main/gcc/ada/a-dirval-vms.adb | 200 - main/gcc/ada/a-dirval.adb | 11 +- main/gcc/ada/a-dirval.ads | 5 +- main/gcc/ada/a-elchha.adb | 17 +- main/gcc/ada/a-excach.adb | 4 +- main/gcc/ada/a-except-2005.adb | 193 +- main/gcc/ada/a-except-2005.ads | 2 +- main/gcc/ada/a-except.adb | 235 +- main/gcc/ada/a-except.ads | 4 +- main/gcc/ada/a-excpol-abort.adb | 4 +- main/gcc/ada/a-exctra.ads | 7 +- main/gcc/ada/a-exexda.adb | 414 +- main/gcc/ada/a-exextr.adb | 4 +- main/gcc/ada/a-exstat.adb | 8 +- main/gcc/ada/a-intnam-linux.ads | 9 +- main/gcc/ada/a-intnam-vms.ads | 80 - main/gcc/ada/a-ngelfu.adb | 8 +- main/gcc/ada/a-ngelfu.ads | 45 +- main/gcc/ada/a-numaux-darwin.adb | 4 +- main/gcc/ada/a-numaux-darwin.ads | 12 +- main/gcc/ada/a-numaux-libc-x86.ads | 13 +- main/gcc/ada/a-numaux-vms.ads | 104 - main/gcc/ada/a-numaux-vxworks.ads | 17 +- main/gcc/ada/a-numaux-x86.adb | 7 +- main/gcc/ada/a-numaux-x86.ads | 11 +- main/gcc/ada/a-numaux.ads | 14 +- main/gcc/ada/a-rbtgbo.adb | 51 +- main/gcc/ada/a-rttiev.adb | 34 +- main/gcc/ada/a-strbou.ads | 4 +- main/gcc/ada/a-stream.ads | 6 +- main/gcc/ada/a-ststio.adb | 23 +- main/gcc/ada/a-suenco.adb | 67 +- main/gcc/ada/a-synbar-posix.adb | 18 +- main/gcc/ada/a-szmzco.ads | 2 +- main/gcc/ada/a-tags.ads | 31 +- main/gcc/ada/a-tasatt.adb | 1129 +-- main/gcc/ada/a-tasatt.ads | 40 +- main/gcc/ada/a-timoau.ads | 2 +- main/gcc/ada/a-ztmoau.adb | 2 +- main/gcc/ada/adabkend.adb | 20 +- main/gcc/ada/adaint.c | 1095 +-- main/gcc/ada/adaint.h | 32 +- main/gcc/ada/ali.adb | 39 +- main/gcc/ada/ali.ads | 24 +- main/gcc/ada/aspects.adb | 3 + main/gcc/ada/aspects.ads | 187 +- main/gcc/ada/atree.adb | 19 +- main/gcc/ada/atree.ads | 7 +- main/gcc/ada/back_end.adb | 11 +- main/gcc/ada/bcheck.adb | 112 +- main/gcc/ada/binde.adb | 17 +- main/gcc/ada/binderr.ads | 4 +- main/gcc/ada/bindgen.adb | 144 +- main/gcc/ada/bindusg.adb | 7 +- main/gcc/ada/butil.adb | 92 +- main/gcc/ada/cal.c | 45 +- main/gcc/ada/checks.adb | 821 +- main/gcc/ada/checks.ads | 52 +- main/gcc/ada/clean.adb | 177 +- main/gcc/ada/cstand.adb | 171 +- main/gcc/ada/cstreams.c | 68 +- main/gcc/ada/debug.adb | 63 +- main/gcc/ada/einfo.adb | 495 +- main/gcc/ada/einfo.ads | 485 +- main/gcc/ada/elists.adb | 15 +- main/gcc/ada/elists.ads | 7 +- main/gcc/ada/err_vars.ads | 11 +- main/gcc/ada/errout.adb | 147 +- main/gcc/ada/errout.ads | 64 +- main/gcc/ada/erroutc.adb | 95 +- main/gcc/ada/errutil.adb | 68 +- main/gcc/ada/exp_aggr.adb | 738 +- main/gcc/ada/exp_atag.adb | 25 +- main/gcc/ada/exp_attr.adb | 868 +- main/gcc/ada/exp_ch11.adb | 100 +- main/gcc/ada/exp_ch11.ads | 7 +- main/gcc/ada/exp_ch3.adb | 647 +- main/gcc/ada/exp_ch4.adb | 718 +- main/gcc/ada/exp_ch5.adb | 221 +- main/gcc/ada/exp_ch6.adb | 2050 +---- main/gcc/ada/exp_ch6.ads | 4 - main/gcc/ada/exp_ch7.adb | 735 +- main/gcc/ada/exp_ch7.ads | 5 - main/gcc/ada/exp_ch9.adb | 141 +- main/gcc/ada/exp_ch9.ads | 5 +- main/gcc/ada/exp_dbug.adb | 62 +- main/gcc/ada/exp_dbug.ads | 25 - main/gcc/ada/exp_disp.adb | 65 +- main/gcc/ada/exp_dist.adb | 24 +- main/gcc/ada/exp_intr.adb | 65 +- main/gcc/ada/exp_intr.ads | 8 +- main/gcc/ada/exp_pakd.adb | 30 +- main/gcc/ada/exp_prag.adb | 278 +- main/gcc/ada/exp_prag.ads | 13 +- main/gcc/ada/exp_smem.adb | 113 +- main/gcc/ada/exp_strm.adb | 9 +- main/gcc/ada/exp_util.adb | 452 +- main/gcc/ada/exp_util.ads | 69 +- main/gcc/ada/exp_vfpt.adb | 690 -- main/gcc/ada/exp_vfpt.ads | 67 - main/gcc/ada/expander.adb | 479 +- main/gcc/ada/expect.c | 44 +- main/gcc/ada/fe.h | 21 +- main/gcc/ada/fname-uf.adb | 6 +- main/gcc/ada/fname.adb | 12 +- main/gcc/ada/fname.ads | 5 +- main/gcc/ada/freeze.adb | 650 +- main/gcc/ada/frontend.adb | 78 +- main/gcc/ada/g-alveop.ads | 14 +- main/gcc/ada/g-awk.adb | 3 +- main/gcc/ada/g-calend.adb | 15 +- main/gcc/ada/g-calend.ads | 4 +- main/gcc/ada/g-catiio.adb | 3 +- main/gcc/ada/g-comlin.adb | 1 - main/gcc/ada/g-debpoo.adb | 142 +- main/gcc/ada/g-decstr.adb | 4 +- main/gcc/ada/g-dirope.adb | 4 +- main/gcc/ada/g-dirope.ads | 53 +- main/gcc/ada/g-eacodu-vms.adb | 71 - main/gcc/ada/g-enblsp-vms-alpha.adb | 128 - main/gcc/ada/g-enblsp-vms-ia64.adb | 125 - main/gcc/ada/g-excact.ads | 8 +- main/gcc/ada/{i-cpp.adb => g-exctra.adb} | 11 +- main/gcc/ada/{gnat.ads => g-exctra.ads} | 14 +- main/gcc/ada/g-expect-vms.adb | 1307 --- main/gcc/ada/g-expect.adb | 39 +- main/gcc/ada/g-expect.ads | 10 +- main/gcc/ada/g-exptty.adb | 24 +- main/gcc/ada/g-forstr.adb | 981 +++ main/gcc/ada/g-forstr.ads | 294 + main/gcc/ada/g-sechas.adb | 74 +- main/gcc/ada/g-sechas.ads | 21 +- main/gcc/ada/g-socket.adb | 9 +- main/gcc/ada/g-socket.ads | 5 +- main/gcc/ada/g-socthi-mingw.adb | 9 +- main/gcc/ada/g-socthi-vms.adb | 502 -- main/gcc/ada/g-socthi-vms.ads | 257 - main/gcc/ada/g-socthi.adb | 3 +- main/gcc/ada/g-sothco.ads | 7 +- main/gcc/ada/g-souinf.ads | 29 +- main/gcc/ada/g-strspl.ads | 2 +- main/gcc/ada/g-timsta.adb | 2 +- main/gcc/ada/g-timsta.ads | 2 +- main/gcc/ada/g-traceb.adb | 4 +- main/gcc/ada/g-traceb.ads | 4 +- main/gcc/ada/g-trasym-vms-alpha.adb | 303 - main/gcc/ada/g-trasym-vms-ia64.adb | 345 - main/gcc/ada/g-trasym.adb | 51 +- main/gcc/ada/{gnat.ads => g-trasym.ads} | 12 +- main/gcc/ada/g-wistsp.ads | 2 +- main/gcc/ada/g-zstspl.ads | 2 +- main/gcc/ada/gcc-interface/Make-lang.in | 51 +- main/gcc/ada/gcc-interface/Makefile.in | 393 +- main/gcc/ada/gcc-interface/ada-tree.h | 52 +- main/gcc/ada/gcc-interface/decl.c | 337 +- main/gcc/ada/gcc-interface/gigi.h | 65 +- main/gcc/ada/gcc-interface/misc.c | 30 +- main/gcc/ada/gcc-interface/trans.c | 747 +- main/gcc/ada/gcc-interface/utils.c | 1522 +--- main/gcc/ada/gcc-interface/utils2.c | 44 +- main/gcc/ada/get_targ.adb | 50 +- main/gcc/ada/get_targ.ads | 5 + main/gcc/ada/gnat.ads | 2 +- main/gcc/ada/gnat1drv.adb | 169 +- main/gcc/ada/gnat_rm.texi | 798 +- main/gcc/ada/gnat_ugn.texi | 9054 +++++++------------- main/gcc/ada/gnatbind.adb | 19 - main/gcc/ada/gnatchop.adb | 126 +- main/gcc/ada/gnatcmd.adb | 530 +- main/gcc/ada/gnatcmd.ads | 24 +- main/gcc/ada/gnatlink.adb | 641 +- main/gcc/ada/gnatls.adb | 35 +- main/gcc/ada/gnatname.adb | 57 +- main/gcc/ada/gnatsym.adb | 359 - main/gcc/ada/hostparm.ads | 15 +- main/gcc/ada/i-cpp.ads | 50 - main/gcc/ada/i-cstrea-vms.adb | 253 - main/gcc/ada/i-cstrea.adb | 6 +- main/gcc/ada/i-cstrea.ads | 15 +- main/gcc/ada/impunit.adb | 2 +- main/gcc/ada/indepsw-aix.adb | 2 +- main/gcc/ada/indepsw-gnu.adb | 2 +- main/gcc/ada/indepsw-mingw.adb | 2 +- main/gcc/ada/indepsw.adb | 2 +- main/gcc/ada/init.c | 4 +- main/gcc/ada/inline.adb | 3286 ++++++- main/gcc/ada/inline.ads | 113 +- main/gcc/ada/interfac.ads | 11 +- main/gcc/ada/krunch.adb | 36 +- main/gcc/ada/krunch.ads | 7 +- main/gcc/ada/layout.adb | 33 +- main/gcc/ada/lib-load.adb | 3 + main/gcc/ada/lib-load.ads | 18 +- main/gcc/ada/lib-util.adb | 7 +- main/gcc/ada/lib-writ.adb | 55 +- main/gcc/ada/lib-writ.ads | 26 +- main/gcc/ada/lib-xref-spark_specific.adb | 1 - main/gcc/ada/lib-xref.adb | 41 +- main/gcc/ada/lib-xref.ads | 8 +- main/gcc/ada/lib.adb | 24 +- main/gcc/ada/lib.ads | 20 +- main/gcc/ada/link.c | 4 +- main/gcc/ada/make.adb | 353 +- main/gcc/ada/makeusg.adb | 3 + main/gcc/ada/makeutl.adb | 153 +- main/gcc/ada/makeutl.ads | 18 +- main/gcc/ada/memtrack.adb | 17 +- main/gcc/ada/mkdir.c | 4 +- main/gcc/ada/mlib-prj.adb | 78 +- main/gcc/ada/mlib-tgt-specific-hpux.adb | 11 +- main/gcc/ada/mlib-tgt-specific-vms-alpha.adb | 509 -- main/gcc/ada/mlib-tgt-specific-vms-ia64.adb | 513 -- main/gcc/ada/mlib-tgt-vms_common.adb | 174 - main/gcc/ada/mlib-tgt-vms_common.ads | 35 - main/gcc/ada/mlib-tgt.ads | 6 +- main/gcc/ada/mlib.adb | 18 +- main/gcc/ada/mlib.ads | 6 +- main/gcc/ada/namet.h | 5 +- main/gcc/ada/nlists.adb | 4 +- main/gcc/ada/nlists.ads | 9 +- main/gcc/ada/opt.adb | 14 +- main/gcc/ada/opt.ads | 267 +- main/gcc/ada/osint-b.adb | 42 +- main/gcc/ada/osint-b.ads | 10 +- main/gcc/ada/osint-c.adb | 26 +- main/gcc/ada/osint-c.ads | 8 +- main/gcc/ada/osint.adb | 167 +- main/gcc/ada/osint.ads | 54 +- main/gcc/ada/output.ads | 9 +- main/gcc/ada/par-ch12.adb | 3 +- main/gcc/ada/par-ch13.adb | 177 +- main/gcc/ada/par-ch2.adb | 15 +- main/gcc/ada/par-ch3.adb | 69 +- main/gcc/ada/par-ch4.adb | 3 +- main/gcc/ada/par-ch5.adb | 5 + main/gcc/ada/par-prag.adb | 8 +- main/gcc/ada/par.adb | 19 +- main/gcc/ada/prepcomp.adb | 20 +- main/gcc/ada/prepcomp.ads | 11 +- main/gcc/ada/prj-attr-pm.adb | 3 +- main/gcc/ada/prj-attr.adb | 82 +- main/gcc/ada/prj-attr.ads | 19 +- main/gcc/ada/prj-conf.adb | 32 +- main/gcc/ada/prj-conf.ads | 9 - main/gcc/ada/prj-dect.adb | 21 +- main/gcc/ada/prj-env.adb | 23 +- main/gcc/ada/prj-makr.adb | 18 +- main/gcc/ada/prj-nmsc.adb | 213 +- main/gcc/ada/prj-pars.adb | 6 +- main/gcc/ada/prj-part.adb | 20 +- main/gcc/ada/prj-pp.adb | 111 +- main/gcc/ada/prj-proc.adb | 164 +- main/gcc/ada/prj-proc.ads | 4 +- main/gcc/ada/prj-strt.adb | 137 +- main/gcc/ada/prj-strt.ads | 23 +- main/gcc/ada/prj-tree.adb | 39 + main/gcc/ada/prj-tree.ads | 20 +- main/gcc/ada/prj-util.adb | 5 +- main/gcc/ada/prj.adb | 45 +- main/gcc/ada/prj.ads | 161 +- main/gcc/ada/projects.texi | 1044 ++- main/gcc/ada/repinfo.adb | 64 +- main/gcc/ada/restrict.adb | 34 +- main/gcc/ada/restrict.ads | 9 +- main/gcc/ada/rtsfind.adb | 8 +- main/gcc/ada/rtsfind.ads | 112 +- main/gcc/ada/s-arit64.adb | 14 +- main/gcc/ada/s-assert.adb | 2 +- main/gcc/ada/s-asthan-vms-alpha.adb | 603 -- main/gcc/ada/s-asthan-vms-ia64.adb | 608 -- main/gcc/ada/s-asthan.adb | 58 - main/gcc/ada/s-asthan.ads | 57 - main/gcc/ada/s-auxdec-vms-alpha.adb | 809 -- main/gcc/ada/s-auxdec-vms-ia64.adb | 576 -- main/gcc/ada/s-auxdec-vms_64.ads | 693 -- main/gcc/ada/s-auxdec.ads | 22 +- main/gcc/ada/s-boarop.ads | 2 +- main/gcc/ada/s-carsi8.ads | 2 +- main/gcc/ada/s-casi16.ads | 2 +- main/gcc/ada/s-casi32.ads | 2 +- main/gcc/ada/s-casi64.ads | 2 +- main/gcc/ada/s-caun16.ads | 2 +- main/gcc/ada/s-caun32.ads | 2 +- main/gcc/ada/s-caun64.ads | 2 +- main/gcc/ada/s-crtl.ads | 14 +- main/gcc/ada/s-direio.adb | 32 +- main/gcc/ada/s-direio.ads | 4 +- main/gcc/ada/s-dsaser.ads | 2 +- main/gcc/ada/s-excmac-gcc.ads | 5 +- main/gcc/ada/{g-exctra.adb => s-exctra.adb} | 37 +- main/gcc/ada/{g-exctra.ads => s-exctra.ads} | 18 +- main/gcc/ada/s-exnint.adb | 2 +- main/gcc/ada/s-exnint.ads | 2 +- main/gcc/ada/s-exnlli.adb | 2 +- main/gcc/ada/s-exnlli.ads | 2 +- main/gcc/ada/s-expint.adb | 2 +- main/gcc/ada/s-expint.ads | 2 +- main/gcc/ada/s-explli.adb | 2 +- main/gcc/ada/s-explli.ads | 2 +- main/gcc/ada/s-expllu.adb | 2 +- main/gcc/ada/s-expuns.adb | 2 +- main/gcc/ada/s-fatgen.adb | 105 +- main/gcc/ada/s-fatgen.ads | 36 +- main/gcc/ada/s-fileio.adb | 352 +- main/gcc/ada/s-filofl.ads | 52 - main/gcc/ada/s-fishfl.ads | 52 - main/gcc/ada/s-fore.adb | 2 +- main/gcc/ada/s-fore.ads | 2 +- main/gcc/ada/s-fvadfl.ads | 54 - main/gcc/ada/s-fvaffl.ads | 54 - main/gcc/ada/s-fvagfl.ads | 54 - main/gcc/ada/s-geveop.ads | 2 +- main/gcc/ada/s-imgbiu.adb | 6 +- main/gcc/ada/s-imgbiu.ads | 2 +- main/gcc/ada/s-imgllb.adb | 6 +- main/gcc/ada/s-imgllb.ads | 2 +- main/gcc/ada/s-imgllw.adb | 6 +- main/gcc/ada/s-imgllw.ads | 2 +- main/gcc/ada/s-imgrea.adb | 7 +- main/gcc/ada/s-imgwiu.adb | 6 +- main/gcc/ada/s-inmaop-vms.adb | 303 - main/gcc/ada/s-interr-hwint.adb | 39 +- main/gcc/ada/s-interr-sigaction.adb | 4 +- main/gcc/ada/s-interr-vms.adb | 1129 --- main/gcc/ada/s-interr.adb | 29 +- main/gcc/ada/s-interr.ads | 6 +- main/gcc/ada/s-intman-vms.adb | 76 - main/gcc/ada/s-intman-vms.ads | 119 - main/gcc/ada/s-intman.ads | 8 +- main/gcc/ada/s-mantis.adb | 2 +- main/gcc/ada/s-mantis.ads | 2 +- main/gcc/ada/s-mastop-vms.adb | 274 - main/gcc/ada/s-mastop.ads | 45 +- main/gcc/ada/s-memcop.ads | 2 +- main/gcc/ada/s-memory-vms_64.adb | 230 - main/gcc/ada/s-memory-vms_64.ads | 129 - main/gcc/ada/s-os_lib.adb | 78 +- main/gcc/ada/s-os_lib.ads | 85 +- main/gcc/ada/s-oscons-tmplt.c | 15 +- main/gcc/ada/s-osinte-android.adb | 15 +- main/gcc/ada/s-osinte-darwin.adb | 15 +- main/gcc/ada/s-osinte-vms.ads | 660 -- main/gcc/ada/s-osprim-mingw.adb | 10 +- main/gcc/ada/s-osprim-posix.adb | 13 +- main/gcc/ada/s-osprim-vms.adb | 209 - main/gcc/ada/s-osprim-vms.ads | 110 - main/gcc/ada/s-pack03.adb | 101 +- main/gcc/ada/s-pack03.ads | 18 +- main/gcc/ada/s-pack05.adb | 101 +- main/gcc/ada/s-pack05.ads | 16 +- main/gcc/ada/s-pack06.adb | 197 +- main/gcc/ada/s-pack06.ads | 27 +- main/gcc/ada/s-pack07.adb | 101 +- main/gcc/ada/s-pack07.ads | 16 +- main/gcc/ada/s-pack09.adb | 101 +- main/gcc/ada/s-pack09.ads | 16 +- main/gcc/ada/s-pack10.adb | 197 +- main/gcc/ada/s-pack10.ads | 27 +- main/gcc/ada/s-pack11.adb | 101 +- main/gcc/ada/s-pack11.ads | 16 +- main/gcc/ada/s-pack12.adb | 197 +- main/gcc/ada/s-pack12.ads | 27 +- main/gcc/ada/s-pack13.adb | 101 +- main/gcc/ada/s-pack13.ads | 16 +- main/gcc/ada/s-pack14.adb | 195 +- main/gcc/ada/s-pack14.ads | 29 +- main/gcc/ada/s-pack15.adb | 101 +- main/gcc/ada/s-pack15.ads | 16 +- main/gcc/ada/s-pack17.adb | 101 +- main/gcc/ada/s-pack17.ads | 16 +- main/gcc/ada/s-pack18.adb | 195 +- main/gcc/ada/s-pack18.ads | 27 +- main/gcc/ada/s-pack19.adb | 101 +- main/gcc/ada/s-pack19.ads | 16 +- main/gcc/ada/s-pack20.adb | 195 +- main/gcc/ada/s-pack20.ads | 27 +- main/gcc/ada/s-pack21.adb | 101 +- main/gcc/ada/s-pack21.ads | 16 +- main/gcc/ada/s-pack22.adb | 195 +- main/gcc/ada/s-pack22.ads | 27 +- main/gcc/ada/s-pack23.adb | 101 +- main/gcc/ada/s-pack23.ads | 16 +- main/gcc/ada/s-pack24.adb | 195 +- main/gcc/ada/s-pack24.ads | 27 +- main/gcc/ada/s-pack25.adb | 103 +- main/gcc/ada/s-pack25.ads | 16 +- main/gcc/ada/s-pack26.adb | 195 +- main/gcc/ada/s-pack26.ads | 27 +- main/gcc/ada/s-pack27.adb | 101 +- main/gcc/ada/s-pack27.ads | 16 +- main/gcc/ada/s-pack28.adb | 195 +- main/gcc/ada/s-pack28.ads | 27 +- main/gcc/ada/s-pack29.adb | 101 +- main/gcc/ada/s-pack29.ads | 16 +- main/gcc/ada/s-pack30.adb | 195 +- main/gcc/ada/s-pack30.ads | 27 +- main/gcc/ada/s-pack31.adb | 101 +- main/gcc/ada/s-pack31.ads | 16 +- main/gcc/ada/s-pack33.adb | 101 +- main/gcc/ada/s-pack33.ads | 16 +- main/gcc/ada/s-pack34.adb | 195 +- main/gcc/ada/s-pack34.ads | 27 +- main/gcc/ada/s-pack35.adb | 101 +- main/gcc/ada/s-pack35.ads | 16 +- main/gcc/ada/s-pack36.adb | 195 +- main/gcc/ada/s-pack36.ads | 27 +- main/gcc/ada/s-pack37.adb | 101 +- main/gcc/ada/s-pack37.ads | 16 +- main/gcc/ada/s-pack38.adb | 195 +- main/gcc/ada/s-pack38.ads | 27 +- main/gcc/ada/s-pack39.adb | 101 +- main/gcc/ada/s-pack39.ads | 16 +- main/gcc/ada/s-pack40.adb | 195 +- main/gcc/ada/s-pack40.ads | 27 +- main/gcc/ada/s-pack41.adb | 101 +- main/gcc/ada/s-pack41.ads | 16 +- main/gcc/ada/s-pack42.adb | 195 +- main/gcc/ada/s-pack42.ads | 27 +- main/gcc/ada/s-pack43.adb | 101 +- main/gcc/ada/s-pack43.ads | 16 +- main/gcc/ada/s-pack44.adb | 195 +- main/gcc/ada/s-pack44.ads | 27 +- main/gcc/ada/s-pack45.adb | 101 +- main/gcc/ada/s-pack45.ads | 16 +- main/gcc/ada/s-pack46.adb | 195 +- main/gcc/ada/s-pack46.ads | 27 +- main/gcc/ada/s-pack47.adb | 101 +- main/gcc/ada/s-pack47.ads | 16 +- main/gcc/ada/s-pack48.adb | 195 +- main/gcc/ada/s-pack48.ads | 27 +- main/gcc/ada/s-pack49.adb | 101 +- main/gcc/ada/s-pack49.ads | 16 +- main/gcc/ada/s-pack50.adb | 195 +- main/gcc/ada/s-pack50.ads | 27 +- main/gcc/ada/s-pack51.adb | 101 +- main/gcc/ada/s-pack51.ads | 16 +- main/gcc/ada/s-pack52.adb | 195 +- main/gcc/ada/s-pack52.ads | 27 +- main/gcc/ada/s-pack53.adb | 101 +- main/gcc/ada/s-pack53.ads | 16 +- main/gcc/ada/s-pack54.adb | 195 +- main/gcc/ada/s-pack54.ads | 27 +- main/gcc/ada/s-pack55.adb | 101 +- main/gcc/ada/s-pack55.ads | 16 +- main/gcc/ada/s-pack56.adb | 195 +- main/gcc/ada/s-pack56.ads | 27 +- main/gcc/ada/s-pack57.adb | 101 +- main/gcc/ada/s-pack57.ads | 16 +- main/gcc/ada/s-pack58.adb | 195 +- main/gcc/ada/s-pack58.ads | 27 +- main/gcc/ada/s-pack59.adb | 101 +- main/gcc/ada/s-pack59.ads | 16 +- main/gcc/ada/s-pack60.adb | 195 +- main/gcc/ada/s-pack60.ads | 27 +- main/gcc/ada/s-pack61.adb | 101 +- main/gcc/ada/s-pack61.ads | 16 +- main/gcc/ada/s-pack62.adb | 195 +- main/gcc/ada/s-pack62.ads | 27 +- main/gcc/ada/s-pack63.adb | 101 +- main/gcc/ada/s-pack63.ads | 16 +- main/gcc/ada/s-parame-ae653.ads | 15 +- main/gcc/ada/s-parame-hpux.ads | 15 +- main/gcc/ada/s-parame-vms-alpha.ads | 216 - main/gcc/ada/s-parame-vms-ia64.ads | 216 - main/gcc/ada/s-parame-vxworks.ads | 15 +- main/gcc/ada/s-parame.ads | 15 +- main/gcc/ada/s-po32gl.adb | 98 - main/gcc/ada/s-po32gl.ads | 80 - main/gcc/ada/s-powtab.ads | 2 +- main/gcc/ada/s-proinf.adb | 2 +- main/gcc/ada/s-ransee-vms.adb | 51 - main/gcc/ada/s-regpat.adb | 64 +- main/gcc/ada/s-regpat.ads | 11 +- main/gcc/ada/s-shasto.ads | 6 +- main/gcc/ada/s-soflin.ads | 8 +- main/gcc/ada/s-stalib.ads | 6 +- main/gcc/ada/s-stchop.adb | 4 +- main/gcc/ada/s-stoele.adb | 5 +- main/gcc/ada/s-taasde.adb | 54 +- main/gcc/ada/s-taasde.ads | 4 +- main/gcc/ada/s-taprop-linux.adb | 6 +- main/gcc/ada/s-taprop-mingw.adb | 3 +- main/gcc/ada/s-taprop-vms.adb | 1278 --- main/gcc/ada/s-taprop-vxworks.adb | 3 +- main/gcc/ada/s-tarest.adb | 6 +- main/gcc/ada/s-tarest.ads | 9 +- main/gcc/ada/s-tasdeb-vms.adb | 2158 ----- main/gcc/ada/s-tasdeb.adb | 179 +- main/gcc/ada/s-tasdeb.ads | 29 +- main/gcc/ada/s-tasinf.adb | 2 +- main/gcc/ada/s-tasini.adb | 32 +- main/gcc/ada/s-tasini.ads | 24 +- main/gcc/ada/s-taskin.ads | 42 +- main/gcc/ada/s-taspri-dummy.ads | 9 +- main/gcc/ada/s-taspri-hpux-dce.ads | 9 +- main/gcc/ada/s-taspri-mingw.ads | 9 +- main/gcc/ada/s-taspri-posix-noaltstack.ads | 9 +- main/gcc/ada/s-taspri-posix.ads | 13 +- main/gcc/ada/s-taspri-solaris.ads | 9 +- main/gcc/ada/s-taspri-vms.ads | 125 - main/gcc/ada/s-taspri-vxworks.ads | 9 +- main/gcc/ada/s-tassta.adb | 46 +- main/gcc/ada/s-tasuti.adb | 68 +- main/gcc/ada/s-tasuti.ads | 31 +- main/gcc/ada/{a-caldel-vms.adb => s-tataat.adb} | 117 +- main/gcc/ada/{s-osinte-vms.adb => s-tataat.ads} | 57 +- main/gcc/ada/s-tpopde-vms.adb | 161 - main/gcc/ada/s-tpopde-vms.ads | 53 - main/gcc/ada/s-tpopsp-vms.adb | 103 - main/gcc/ada/s-tporft.adb | 11 +- main/gcc/ada/s-traceb-hpux.adb | 31 +- main/gcc/ada/s-traceb-mastop.adb | 30 +- main/gcc/ada/s-traceb.adb | 34 +- main/gcc/ada/s-traceb.ads | 31 +- main/gcc/ada/s-traces-default.adb | 2 +- main/gcc/ada/s-traces.adb | 2 +- main/gcc/ada/s-traent-vms.adb | 61 - main/gcc/ada/s-traent-vms.ads | 60 - main/gcc/ada/s-traent.adb | 6 +- main/gcc/ada/s-traent.ads | 8 +- main/gcc/ada/{g-trasym.adb => s-trasym.adb} | 18 +- main/gcc/ada/{g-trasym.ads => s-trasym.ads} | 41 +- main/gcc/ada/s-tratas-default.adb | 2 +- main/gcc/ada/s-tratas.adb | 2 +- main/gcc/ada/s-tratas.ads | 2 +- main/gcc/ada/s-unstyp.ads | 7 +- main/gcc/ada/s-vaflop-vms-alpha.adb | 695 -- main/gcc/ada/s-vaflop.adb | 503 -- main/gcc/ada/s-vaflop.ads | 247 - main/gcc/ada/s-vector.ads | 2 +- main/gcc/ada/s-vmexta.adb | 187 - main/gcc/ada/s-vmexta.ads | 67 - main/gcc/ada/s-vxwork-x86.ads | 2 +- main/gcc/ada/s-wwdwch.ads | 2 +- main/gcc/ada/scans.ads | 4 + main/gcc/ada/scng.adb | 2 +- main/gcc/ada/scos.h | 2 +- main/gcc/ada/sem.adb | 36 +- main/gcc/ada/sem.ads | 52 +- main/gcc/ada/sem_aggr.adb | 198 +- main/gcc/ada/sem_attr.adb | 1537 ++-- main/gcc/ada/sem_attr.ads | 96 +- main/gcc/ada/sem_aux.adb | 100 +- main/gcc/ada/sem_aux.ads | 27 +- main/gcc/ada/sem_case.adb | 121 +- main/gcc/ada/sem_cat.adb | 5 +- main/gcc/ada/sem_cat.ads | 12 +- main/gcc/ada/sem_ch10.adb | 168 +- main/gcc/ada/sem_ch11.adb | 8 +- main/gcc/ada/sem_ch12.adb | 444 +- main/gcc/ada/sem_ch13.adb | 1330 ++- main/gcc/ada/sem_ch13.ads | 11 + main/gcc/ada/sem_ch3.adb | 1291 +-- main/gcc/ada/sem_ch3.ads | 80 +- main/gcc/ada/sem_ch4.adb | 182 +- main/gcc/ada/sem_ch5.adb | 262 +- main/gcc/ada/sem_ch6.adb | 2792 ++---- main/gcc/ada/sem_ch6.ads | 33 - main/gcc/ada/sem_ch7.adb | 93 +- main/gcc/ada/sem_ch8.adb | 827 +- main/gcc/ada/sem_ch9.adb | 52 +- main/gcc/ada/sem_dim.adb | 20 +- main/gcc/ada/sem_disp.adb | 152 +- main/gcc/ada/sem_disp.ads | 21 +- main/gcc/ada/sem_elab.adb | 270 +- main/gcc/ada/sem_eval.adb | 1441 +++- main/gcc/ada/sem_eval.ads | 143 +- main/gcc/ada/sem_intr.adb | 19 +- main/gcc/ada/sem_mech.adb | 205 +- main/gcc/ada/sem_mech.ads | 42 +- main/gcc/ada/sem_prag.adb | 2022 ++--- main/gcc/ada/sem_prag.ads | 24 +- main/gcc/ada/sem_res.adb | 703 +- main/gcc/ada/sem_util.adb | 1509 ++-- main/gcc/ada/sem_util.ads | 144 +- main/gcc/ada/sem_vfpt.adb | 168 - main/gcc/ada/sem_vfpt.ads | 55 - main/gcc/ada/sem_warn.adb | 108 +- main/gcc/ada/sem_warn.ads | 16 +- main/gcc/ada/set_targ.adb | 597 +- main/gcc/ada/sigtramp-armvxw.c | 250 - .../ada/{sigtramp-ppcvxw.c => sigtramp-vxworks.c} | 174 +- main/gcc/ada/sinfo.adb | 88 +- main/gcc/ada/sinfo.ads | 158 +- main/gcc/ada/sinput-c.adb | 16 +- main/gcc/ada/sinput.adb | 28 +- main/gcc/ada/sinput.ads | 9 +- main/gcc/ada/snames.adb-tmpl | 56 +- main/gcc/ada/snames.ads-tmpl | 81 +- main/gcc/ada/socket.c | 52 +- main/gcc/ada/sprint.adb | 99 +- main/gcc/ada/stand.adb | 2 +- main/gcc/ada/stand.ads | 3 +- main/gcc/ada/style.ads | 6 +- main/gcc/ada/styleg.adb | 36 +- main/gcc/ada/styleg.ads | 16 +- main/gcc/ada/switch-b.adb | 14 - main/gcc/ada/switch-c.adb | 151 +- main/gcc/ada/switch-m.adb | 8 +- main/gcc/ada/symbols-processing-vms-alpha.adb | 318 - main/gcc/ada/symbols-processing-vms-ia64.adb | 430 - main/gcc/ada/symbols-vms.adb | 637 -- main/gcc/ada/symbols.ads | 9 +- main/gcc/ada/sysdep.c | 3 +- main/gcc/ada/system-vms-ia64.ads | 257 - main/gcc/ada/system-vms_64.ads | 257 - main/gcc/ada/system-vxworks-arm.ads | 6 +- main/gcc/ada/system-vxworks-ppc.ads | 14 +- main/gcc/ada/system.ads | 3 +- main/gcc/ada/targparm.adb | 48 +- main/gcc/ada/targparm.ads | 23 +- main/gcc/ada/tb-alvms.c | 395 - main/gcc/ada/tb-alvxw.c | 940 -- main/gcc/ada/tb-ivms.c | 88 - main/gcc/ada/tbuild.adb | 26 +- main/gcc/ada/tbuild.ads | 40 +- main/gcc/ada/tempdir.adb | 24 +- main/gcc/ada/tracebak.c | 16 +- main/gcc/ada/tree_io.adb | 2 +- main/gcc/ada/treepr.adb | 91 +- main/gcc/ada/treepr.ads | 43 +- main/gcc/ada/types.adb | 2 +- main/gcc/ada/types.ads | 99 +- main/gcc/ada/types.h | 5 +- main/gcc/ada/ug_words | 271 - main/gcc/ada/uname.ads | 2 +- main/gcc/ada/usage.adb | 2 +- main/gcc/ada/vms_cmds.ads | 56 - main/gcc/ada/vms_conv.adb | 2349 ----- main/gcc/ada/vms_conv.ads | 159 - main/gcc/ada/vms_data.ads | 7772 ----------------- main/gcc/ada/vxaddr2line.adb | 18 +- main/gcc/ada/vxworks-crtbe-link.spec | 13 + main/gcc/ada/vxworks-ppc-link.spec | 6 + main/gcc/ada/warnsw.adb | 60 +- main/gcc/ada/widechar.ads | 2 +- main/gcc/ada/xgnatugn.adb | 1086 --- main/gcc/ada/xr_tabls.adb | 11 +- main/gcc/ada/xr_tabls.ads | 6 +- main/gcc/ada/xsnamest.adb | 6 +- main/gcc/asan.c | 25 +- main/gcc/c-family/ChangeLog | 49 + main/gcc/c-family/array-notation-common.c | 8 + main/gcc/c-family/c-common.c | 48 +- main/gcc/c-family/c-common.h | 1 - main/gcc/c-family/c-gimplify.c | 9 +- main/gcc/c-family/c-ubsan.c | 98 + main/gcc/c-family/c-ubsan.h | 2 + main/gcc/c-family/c.opt | 12 +- main/gcc/c-family/cilk.c | 60 +- main/gcc/c/ChangeLog | 29 + main/gcc/c/c-array-notation.c | 19 + main/gcc/c/c-decl.c | 24 +- main/gcc/c/c-typeck.c | 30 +- main/gcc/calls.c | 11 +- main/gcc/cfgexpand.c | 12 +- main/gcc/cfgloop.c | 18 +- main/gcc/cgraph.c | 18 +- main/gcc/cgraph.h | 130 +- main/gcc/cgraphbuild.c | 7 +- main/gcc/cgraphunit.c | 35 +- main/gcc/common.opt | 14 +- main/gcc/config.gcc | 8 +- main/gcc/config.in | 6 + main/gcc/config/aarch64/aarch64-builtins.c | 14 + main/gcc/config/aarch64/aarch64-linux.h | 2 + main/gcc/config/aarch64/aarch64-protos.h | 3 + main/gcc/config/aarch64/aarch64-simd-builtins.def | 3 - main/gcc/config/aarch64/aarch64-simd.md | 4 +- main/gcc/config/aarch64/aarch64.c | 95 +- main/gcc/config/aarch64/aarch64.md | 28 +- main/gcc/config/aarch64/arm_neon.h | 115 +- main/gcc/config/aarch64/predicates.md | 55 +- main/gcc/config/alpha/elf.h | 4 + main/gcc/config/arm/arm.c | 2 +- main/gcc/config/arm/neon.md | 8 +- main/gcc/config/avr/avr-c.c | 6 +- main/gcc/config/i386/driver-i386.c | 5 +- main/gcc/config/i386/i386.c | 16 +- main/gcc/config/mips/mips.c | 11 +- main/gcc/config/mips/mips.h | 6 + main/gcc/config/moxie/moxiebox.h | 47 + main/gcc/config/pa/pa-protos.h | 1 - main/gcc/config/pa/pa.c | 29 +- main/gcc/config/pa/pa.h | 2 +- main/gcc/config/rs6000/freebsd64.h | 2 +- main/gcc/config/rs6000/linux.h | 24 - main/gcc/config/rs6000/linux64.h | 26 +- main/gcc/config/rs6000/rs6000-protos.h | 1 + main/gcc/config/rs6000/rs6000.c | 199 +- main/gcc/config/rs6000/rs6000.h | 164 +- main/gcc/config/rs6000/rs6000.md | 2 + main/gcc/config/rs6000/sysv4.h | 3 +- main/gcc/config/s390/s390.c | 5 +- main/gcc/config/sh/predicates.md | 8 + main/gcc/config/sh/sh.c | 26 + main/gcc/config/vxworksae.h | 4 + main/gcc/configure | 2 +- main/gcc/configure.ac | 2 +- main/gcc/coverage.c | 57 +- main/gcc/coverage.h | 1 + main/gcc/cp/ChangeLog | 110 + main/gcc/cp/class.c | 8 +- main/gcc/cp/cp-array-notation.c | 25 +- main/gcc/cp/cp-gimplify.c | 33 +- main/gcc/cp/cp-tree.h | 2 +- main/gcc/cp/decl.c | 83 +- main/gcc/cp/decl2.c | 71 +- main/gcc/cp/error.c | 8 +- main/gcc/cp/init.c | 44 +- main/gcc/cp/method.c | 11 +- main/gcc/cp/name-lookup.c | 13 +- main/gcc/cp/optimize.c | 23 +- main/gcc/cp/parser.c | 60 +- main/gcc/cp/pt.c | 88 +- main/gcc/cp/semantics.c | 15 +- main/gcc/cp/tree.c | 16 +- main/gcc/cp/typeck.c | 21 +- main/gcc/cp/typeck2.c | 3 +- main/gcc/cprop.c | 6 +- main/gcc/cse.c | 12 +- main/gcc/data-streamer-out.c | 76 +- main/gcc/data-streamer.h | 2 + main/gcc/doc/cpp.texi | 4 +- main/gcc/doc/extend.texi | 11 + main/gcc/doc/invoke.texi | 110 +- main/gcc/doc/md.texi | 22 +- main/gcc/doc/sourcebuild.texi | 9 + main/gcc/dwarf2out.c | 125 +- main/gcc/except.c | 15 +- main/gcc/except.h | 3 +- main/gcc/explow.c | 8 +- main/gcc/flag-types.h | 33 +- main/gcc/fold-const.c | 111 +- main/gcc/fold-const.h | 2 +- main/gcc/fortran/ChangeLog | 40 +- main/gcc/fortran/check.c | 7 +- main/gcc/fortran/intrinsic.c | 6 +- main/gcc/fortran/intrinsic.texi | 8 +- main/gcc/fortran/openmp.c | 20 +- main/gcc/fortran/simplify.c | 4 +- main/gcc/fortran/trans-decl.c | 10 +- main/gcc/fortran/trans-expr.c | 24 +- main/gcc/fortran/trans-intrinsic.c | 165 +- main/gcc/function.c | 17 +- main/gcc/gcc.c | 9 +- main/gcc/gcov-io.c | 2 +- main/gcc/gcov-tool.c | 6 +- main/gcc/gengtype.c | 39 +- main/gcc/gimple-fold.c | 59 +- main/gcc/gimple-fold.h | 1 - main/gcc/gimple-iterator.h | 24 + main/gcc/gimple-ssa-isolate-paths.c | 104 +- main/gcc/gimple-ssa-strength-reduction.c | 29 +- main/gcc/gimple-walk.c | 2 +- main/gcc/gimple-walk.h | 2 +- main/gcc/gimplify.c | 26 +- main/gcc/go/ChangeLog | 7 +- main/gcc/go/go-gcc.cc | 4 +- main/gcc/godump.c | 57 +- main/gcc/graphite-isl-ast-to-gimple.c | 54 +- main/gcc/graphite-sese-to-poly.c | 2 + main/gcc/hash-map.h | 16 +- main/gcc/{hash-map.h => hash-set.h} | 116 +- main/gcc/inchash.c | 75 + main/gcc/inchash.h | 137 + main/gcc/ipa-devirt.c | 659 +- main/gcc/ipa-inline-transform.c | 2 +- main/gcc/ipa-prop.c | 10 +- main/gcc/ipa-prop.h | 1 + main/gcc/ipa-pure-const.c | 33 +- main/gcc/ipa-utils.c | 267 +- main/gcc/ipa-utils.h | 26 +- main/gcc/ipa-visibility.c | 5 +- main/gcc/ipa.c | 79 +- main/gcc/ira-costs.c | 14 + main/gcc/ira.c | 21 +- main/gcc/langhooks.c | 5 +- main/gcc/lto-cgraph.c | 38 +- main/gcc/lto-opts.c | 6 +- main/gcc/lto-section-out.c | 98 +- main/gcc/lto-streamer-in.c | 1 - main/gcc/lto-streamer-out.c | 639 +- main/gcc/lto-streamer.h | 22 +- main/gcc/lto/ChangeLog | 42 + main/gcc/lto/lto-object.c | 4 +- main/gcc/lto/lto-partition.c | 8 +- main/gcc/lto/lto-partition.h | 3 +- main/gcc/lto/lto.c | 53 +- main/gcc/omp-low.c | 41 +- main/gcc/optabs.c | 13 +- main/gcc/opts.c | 39 +- main/gcc/params.def | 8 + main/gcc/passes.c | 2 +- main/gcc/predict.c | 52 +- main/gcc/reginfo.c | 7 +- main/gcc/rtl.c | 79 +- main/gcc/rtl.h | 3 +- main/gcc/rtlanal.c | 19 + main/gcc/rtlhash.c | 107 + main/gcc/{lto/lto-partition.h => rtlhash.h} | 32 +- main/gcc/sched-deps.c | 51 +- main/gcc/simplify-rtx.c | 44 + main/gcc/stmt.c | 6 +- main/gcc/stor-layout.c | 21 + main/gcc/stor-layout.h | 3 + main/gcc/testsuite/ChangeLog | 266 + main/gcc/testsuite/c-c++-common/addrtmp.c | 29 + .../c-c++-common/cilk-plus/AN/pr61455-2.c | 13 + .../testsuite/c-c++-common/cilk-plus/AN/pr61455.c | 9 + .../testsuite/c-c++-common/cilk-plus/AN/pr61963.c | 9 + main/gcc/testsuite/c-c++-common/ubsan/align-1.c | 41 + main/gcc/testsuite/c-c++-common/ubsan/align-2.c | 56 + main/gcc/testsuite/c-c++-common/ubsan/align-3.c | 66 + main/gcc/testsuite/c-c++-common/ubsan/align-4.c | 14 + main/gcc/testsuite/c-c++-common/ubsan/align-5.c | 15 + main/gcc/testsuite/c-c++-common/ubsan/attrib-4.c | 15 + main/gcc/testsuite/c-c++-common/uninit-G.c | 5 +- .../testsuite/g++.dg/compat/struct-layout-1.exp | 3 + main/gcc/testsuite/g++.dg/cpp0x/vt-57397-1.C | 22 + main/gcc/testsuite/g++.dg/cpp0x/vt-57397-2.C | 24 + .../g++.dg/cpp1z/typename-tmpl-tmpl-parm-neg.C | 11 + .../g++.dg/cpp1z/typename-tmpl-tmpl-parm-ped-neg.C | 28 + .../g++.dg/cpp1z/typename-tmpl-tmpl-parm.C | 28 + main/gcc/testsuite/g++.dg/init/explicit2.C | 8 + main/gcc/testsuite/g++.dg/ipa/devirt-34.C | 20 + main/gcc/testsuite/g++.dg/opt/devirt4.C | 7 +- main/gcc/testsuite/g++.dg/other/default10.C | 4 + main/gcc/testsuite/g++.dg/other/default3.C | 2 +- main/gcc/testsuite/g++.dg/other/default9.C | 18 + main/gcc/testsuite/g++.dg/tc1/dr217-2.C | 13 + main/gcc/testsuite/g++.dg/template/dtor9.C | 1 - main/gcc/testsuite/g++.dg/template/dtor9a.C | 13 - main/gcc/testsuite/g++.dg/template/friend56.C | 13 + main/gcc/testsuite/g++.dg/tree-prof/morefunc.C | 55 + main/gcc/testsuite/g++.dg/tree-prof/reorder.C | 48 + .../testsuite/g++.dg/tree-prof/reorder_class1.h | 11 + .../testsuite/g++.dg/tree-prof/reorder_class2.h | 12 + main/gcc/testsuite/g++.dg/tree-prof/tree-prof.exp | 4 +- main/gcc/testsuite/g++.dg/ubsan/align-1.C | 27 + main/gcc/testsuite/g++.dg/ubsan/align-2.C | 45 + main/gcc/testsuite/g++.dg/ubsan/align-3.C | 45 + main/gcc/testsuite/g++.dg/ubsan/attrib-1.C | 27 + main/gcc/testsuite/g++.dg/ubsan/null-1.C | 30 + main/gcc/testsuite/g++.dg/ubsan/null-2.C | 39 + main/gcc/testsuite/g++.dg/warn/Wsuggest-final.C | 14 + .../testsuite/gcc.c-torture/execute/20050316-1.x | 1 + .../testsuite/gcc.c-torture/execute/20050316-3.x | 2 + .../testsuite/gcc.c-torture/execute/20050604-1.x | 1 + main/gcc/testsuite/gcc.c-torture/execute/pr23135.x | 2 + main/gcc/testsuite/gcc.dg/Wdesignated-init-2.c | 15 + main/gcc/testsuite/gcc.dg/Wdesignated-init.c | 107 + main/gcc/testsuite/gcc.dg/Wstrict-overflow-25.c | 2 +- main/gcc/testsuite/gcc.dg/case-bogus-1.c | 8 + .../gcc.dg/cproj-fails-with-broken-glibc.c | 2 +- main/gcc/testsuite/gcc.dg/fold-abs-5.c | 11 + main/gcc/testsuite/gcc.dg/fold-compare-8.c | 2 +- main/gcc/testsuite/gcc.dg/fold-cstring.c | 44 + main/gcc/testsuite/gcc.dg/fold-cvect.c | 38 + .../testsuite/gcc.dg/graphite/isl-ast-gen-if-1.c | 37 + .../testsuite/gcc.dg/graphite/isl-ast-gen-if-2.c | 31 + main/gcc/testsuite/gcc.dg/pr51879-7.c | 2 - main/gcc/testsuite/gcc.dg/pr61077.c | 4 +- main/gcc/testsuite/gcc.dg/pr61756.c | 15 + main/gcc/testsuite/gcc.dg/pr61762.c | 19 + main/gcc/testsuite/gcc.dg/pr61861.c | 37 + main/gcc/testsuite/gcc.dg/pr61868.c | 9 + main/gcc/testsuite/gcc.dg/torture/ftrapv-1.c | 37 + main/gcc/testsuite/gcc.dg/torture/pr61964.c | 33 + .../aarch64/legitimize_stack_var_before_reload_1.c | 21 + .../gcc.target/aarch64/scalar_intrinsics.c | 17 +- .../testsuite/gcc.target/aarch64/simd/vpaddd_f64.c | 27 + .../testsuite/gcc.target/aarch64/simd/vpaddd_s64.c | 27 + .../testsuite/gcc.target/aarch64/simd/vpaddd_u64.c | 27 + main/gcc/testsuite/gcc.target/arm/pr61948.c | 16 + .../gcc.target/i386/avx512f-vbroadcastf64x4-2.c | 2 +- main/gcc/testsuite/gcc.target/i386/pr44551-1.c | 15 + main/gcc/testsuite/gcc.target/i386/pr61801.c | 22 + .../gcc/testsuite/gcc.target/mips/const-anchor-1.c | 4 +- .../gcc/testsuite/gcc.target/mips/const-anchor-2.c | 4 +- .../mips/{const-anchor-1.c => const-anchor-3.c} | 5 +- .../mips/{const-anchor-2.c => const-anchor-4.c} | 5 +- .../gcc.target/powerpc/ppc64-abi-warn-1.c | 12 + .../gcc.target/powerpc/ppc64-abi-warn-2.c | 11 + .../gcc.target/powerpc/ppc64-abi-warn-3.c | 9 + main/gcc/testsuite/gcc.target/powerpc/pr60102.c | 11 + main/gcc/testsuite/gfortran.dg/pr61921.f90 | 15 + main/gcc/testsuite/gfortran.dg/sizeof_2.f90 | 2 +- main/gcc/testsuite/gfortran.dg/storage_size_1.f08 | 2 +- main/gcc/testsuite/gfortran.dg/storage_size_5.f90 | 44 + main/gcc/testsuite/gnat.dg/case_null.adb | 2 +- main/gcc/testsuite/gnat.dg/discr6.adb | 33 - main/gcc/testsuite/gnat.dg/discr6_pkg.ads | 16 - main/gcc/testsuite/gnat.dg/specs/debug1.ads | 2 +- main/gcc/testsuite/gnat.dg/specs/formal_type.ads | 3 +- main/gcc/testsuite/lib/target-supports.exp | 59 +- main/gcc/toplev.c | 64 +- main/gcc/tree-cfg.c | 129 +- main/gcc/tree-cfgcleanup.c | 10 +- main/gcc/tree-core.h | 4 +- main/gcc/tree-eh.c | 68 +- main/gcc/tree-eh.h | 6 +- main/gcc/tree-emutls.c | 113 +- main/gcc/tree-inline.c | 130 +- main/gcc/tree-inline.h | 11 +- main/gcc/tree-loop-distribution.c | 2 +- main/gcc/tree-nested.c | 84 +- main/gcc/tree-outof-ssa.c | 26 +- main/gcc/tree-pretty-print.c | 8 +- main/gcc/tree-sra.c | 119 +- main/gcc/tree-ssa-ccp.c | 97 +- main/gcc/tree-ssa-dom.c | 82 +- main/gcc/tree-ssa-loop-im.c | 21 +- main/gcc/tree-ssa-loop-ivopts.c | 30 +- main/gcc/tree-ssa-loop-niter.c | 11 +- main/gcc/tree-ssa-loop.c | 5 +- main/gcc/tree-ssa-phiopt.c | 23 +- main/gcc/tree-ssa-pre.c | 1 + main/gcc/tree-ssa-reassoc.c | 17 +- main/gcc/tree-ssa-sccvn.c | 45 +- main/gcc/tree-ssa-sccvn.h | 6 +- main/gcc/tree-ssa-structalias.c | 55 +- main/gcc/tree-ssa-tail-merge.c | 37 +- main/gcc/tree-ssa-threadedge.c | 20 +- main/gcc/tree-ssa-uninit.c | 78 +- main/gcc/tree-ssa.c | 81 +- main/gcc/tree-ssa.h | 2 +- main/gcc/tree.c | 260 +- main/gcc/tree.h | 25 +- main/gcc/ubsan.c | 171 +- main/gcc/ubsan.h | 7 +- main/gcc/value-prof.c | 28 +- main/gcc/var-tracking.c | 54 +- main/gcc/varasm.c | 10 +- main/gcc/varpool.c | 22 +- main/libcpp/ChangeLog | 7 + main/libcpp/macro.c | 11 +- main/libffi/ChangeLog | 5 + main/libffi/src/alpha/ffi.c | 3 +- main/libgcc/ChangeLog | 97 + main/libgcc/config.host | 4 +- main/libgcc/config/i386/cygming-crtbegin.c | 17 +- main/libgcc/config/rs6000/ibm-ldouble.c | 73 +- main/libgcc/config/rs6000/linux-unwind.h | 4 +- main/libgcc/config/s390/tpf-unwind.h | 65 +- main/libgcc/dyn-ipa.c | 2 +- main/libgcc/libgcov-driver-system.c | 78 +- main/libgcc/libgcov-driver.c | 172 +- main/libgcc/libgcov-interface.c | 34 +- main/libgcc/libgcov-util.c | 19 +- main/libgcc/libgcov.h | 19 + main/libgfortran/ChangeLog | 4 + main/libgfortran/runtime/memory.c | 4 +- main/libgo/runtime/go-caller.c | 12 + main/libgo/runtime/mem.c | 2 +- main/libgomp/ChangeLog | 43 +- main/libgomp/libgomp.h | 17 +- main/libgomp/task.c | 354 +- main/libgomp/testsuite/libgomp.c/depend-10.c | 3 + main/libgomp/testsuite/libgomp.c/depend-5.c | 98 + main/libgomp/testsuite/libgomp.c/depend-6.c | 3 + main/libgomp/testsuite/libgomp.c/depend-7.c | 3 + main/libgomp/testsuite/libgomp.c/depend-8.c | 3 + main/libgomp/testsuite/libgomp.c/depend-9.c | 3 + main/libitm/ChangeLog | 5 + main/libitm/config/aarch64/sjlj.S | 3 +- main/libobjc/ChangeLog | 7 + main/libobjc/encoding.c | 1 + main/libstdc++-v3/ChangeLog | 77 + .../abi/post/alpha-linux-gnu/baseline_symbols.txt | 11 + main/libstdc++-v3/include/bits/random.h | 2 + main/libstdc++-v3/include/bits/random.tcc | 3 + main/libstdc++-v3/include/experimental/string_view | 8 +- main/libstdc++-v3/include/ext/random.tcc | 2 +- main/libstdc++-v3/include/ext/rope | 7 +- main/libstdc++-v3/include/std/tuple | 28 +- main/libstdc++-v3/libsupc++/atexit_thread.cc | 6 +- main/libstdc++-v3/python/libstdcxx/v6/printers.py | 4 +- .../move_assign_neg.cc => 20_util/tuple/61947.cc} | 40 +- .../testsuite/20_util/uses_allocator/cons_neg.cc | 2 +- .../forward_list/debug/move_assign_neg.cc | 2 +- .../23_containers/map/debug/move_assign_neg.cc | 3 +- .../multimap/debug/move_assign_neg.cc | 3 +- .../multiset/debug/move_assign_neg.cc | 2 +- .../23_containers/set/debug/move_assign_neg.cc | 2 +- .../unordered_map/debug/move_assign_neg.cc | 3 +- .../unordered_multimap/debug/move_assign_neg.cc | 3 +- .../unordered_multiset/debug/move_assign_neg.cc | 2 +- .../unordered_set/debug/move_assign_neg.cc | 2 +- .../23_containers/vector/debug/move_assign_neg.cc | 2 +- .../26_numerics/headers/complex/synopsis.cc | 2 +- .../testsuite/26_numerics/random/pr60037-neg.cc | 15 + .../random/hypergeometric_distribution/pr60037.cc | 23 + .../debug/move_assign_neg.cc => ext/rope/61946.cc} | 38 +- .../testsuite/util/testsuite_allocator.h | 342 +- main/maintainer-scripts/ChangeLog | 4 + main/maintainer-scripts/update_web_docs_svn | 18 +- 1046 files changed, 53964 insertions(+), 72582 deletions(-) create mode 100644 main/config/mh-alpha-linux delete mode 100644 main/gcc/ada/a-calend-vms.adb delete mode 100644 main/gcc/ada/a-calend-vms.ads delete mode 100644 main/gcc/ada/a-dirval-vms.adb delete mode 100644 main/gcc/ada/a-intnam-vms.ads delete mode 100644 main/gcc/ada/a-numaux-vms.ads rewrite main/gcc/ada/a-tasatt.adb (83%) delete mode 100644 main/gcc/ada/exp_vfpt.adb delete mode 100644 main/gcc/ada/exp_vfpt.ads delete mode 100644 main/gcc/ada/g-eacodu-vms.adb delete mode 100644 main/gcc/ada/g-enblsp-vms-alpha.adb delete mode 100644 main/gcc/ada/g-enblsp-vms-ia64.adb rename main/gcc/ada/{i-cpp.adb => g-exctra.adb} (85%) copy main/gcc/ada/{gnat.ads => g-exctra.ads} (81%) delete mode 100644 main/gcc/ada/g-expect-vms.adb create mode 100644 main/gcc/ada/g-forstr.adb create mode 100644 main/gcc/ada/g-forstr.ads delete mode 100644 main/gcc/ada/g-socthi-vms.adb delete mode 100644 main/gcc/ada/g-socthi-vms.ads delete mode 100644 main/gcc/ada/g-trasym-vms-alpha.adb delete mode 100644 main/gcc/ada/g-trasym-vms-ia64.adb copy main/gcc/ada/{gnat.ads => g-trasym.ads} (87%) delete mode 100644 main/gcc/ada/gnatsym.adb delete mode 100644 main/gcc/ada/i-cpp.ads delete mode 100644 main/gcc/ada/i-cstrea-vms.adb delete mode 100644 main/gcc/ada/mlib-tgt-specific-vms-alpha.adb delete mode 100644 main/gcc/ada/mlib-tgt-specific-vms-ia64.adb delete mode 100644 main/gcc/ada/mlib-tgt-vms_common.adb delete mode 100644 main/gcc/ada/mlib-tgt-vms_common.ads delete mode 100644 main/gcc/ada/s-asthan-vms-alpha.adb delete mode 100644 main/gcc/ada/s-asthan-vms-ia64.adb delete mode 100644 main/gcc/ada/s-asthan.adb delete mode 100644 main/gcc/ada/s-asthan.ads delete mode 100644 main/gcc/ada/s-auxdec-vms-alpha.adb delete mode 100644 main/gcc/ada/s-auxdec-vms-ia64.adb delete mode 100644 main/gcc/ada/s-auxdec-vms_64.ads copy main/gcc/ada/{g-exctra.adb => s-exctra.adb} (80%) copy main/gcc/ada/{g-exctra.ads => s-exctra.ads} (90%) delete mode 100644 main/gcc/ada/s-filofl.ads delete mode 100644 main/gcc/ada/s-fishfl.ads delete mode 100644 main/gcc/ada/s-fvadfl.ads delete mode 100644 main/gcc/ada/s-fvaffl.ads delete mode 100644 main/gcc/ada/s-fvagfl.ads delete mode 100644 main/gcc/ada/s-inmaop-vms.adb delete mode 100644 main/gcc/ada/s-interr-vms.adb delete mode 100644 main/gcc/ada/s-intman-vms.adb delete mode 100644 main/gcc/ada/s-intman-vms.ads delete mode 100644 main/gcc/ada/s-mastop-vms.adb delete mode 100644 main/gcc/ada/s-memory-vms_64.adb delete mode 100644 main/gcc/ada/s-memory-vms_64.ads delete mode 100644 main/gcc/ada/s-osinte-vms.ads delete mode 100644 main/gcc/ada/s-osprim-vms.adb delete mode 100644 main/gcc/ada/s-osprim-vms.ads delete mode 100644 main/gcc/ada/s-parame-vms-alpha.ads delete mode 100644 main/gcc/ada/s-parame-vms-ia64.ads delete mode 100644 main/gcc/ada/s-po32gl.adb delete mode 100644 main/gcc/ada/s-po32gl.ads delete mode 100644 main/gcc/ada/s-ransee-vms.adb delete mode 100644 main/gcc/ada/s-taprop-vms.adb delete mode 100644 main/gcc/ada/s-tasdeb-vms.adb delete mode 100644 main/gcc/ada/s-taspri-vms.ads rename main/gcc/ada/{a-caldel-vms.adb => s-tataat.adb} (51%) rename main/gcc/ada/{s-osinte-vms.adb => s-tataat.ads} (55%) delete mode 100644 main/gcc/ada/s-tpopde-vms.adb delete mode 100644 main/gcc/ada/s-tpopde-vms.ads delete mode 100644 main/gcc/ada/s-tpopsp-vms.adb delete mode 100644 main/gcc/ada/s-traent-vms.adb delete mode 100644 main/gcc/ada/s-traent-vms.ads copy main/gcc/ada/{g-trasym.adb => s-trasym.adb} (87%) copy main/gcc/ada/{g-trasym.ads => s-trasym.ads} (75%) delete mode 100644 main/gcc/ada/s-vaflop-vms-alpha.adb delete mode 100644 main/gcc/ada/s-vaflop.adb delete mode 100644 main/gcc/ada/s-vaflop.ads delete mode 100644 main/gcc/ada/s-vmexta.adb delete mode 100644 main/gcc/ada/s-vmexta.ads delete mode 100644 main/gcc/ada/sem_vfpt.adb delete mode 100644 main/gcc/ada/sem_vfpt.ads delete mode 100644 main/gcc/ada/sigtramp-armvxw.c rename main/gcc/ada/{sigtramp-ppcvxw.c => sigtramp-vxworks.c} (67%) delete mode 100644 main/gcc/ada/symbols-processing-vms-alpha.adb delete mode 100644 main/gcc/ada/symbols-processing-vms-ia64.adb delete mode 100644 main/gcc/ada/symbols-vms.adb delete mode 100644 main/gcc/ada/system-vms-ia64.ads delete mode 100644 main/gcc/ada/system-vms_64.ads delete mode 100644 main/gcc/ada/tb-alvms.c delete mode 100644 main/gcc/ada/tb-alvxw.c delete mode 100644 main/gcc/ada/tb-ivms.c delete mode 100644 main/gcc/ada/ug_words delete mode 100644 main/gcc/ada/vms_cmds.ads delete mode 100644 main/gcc/ada/vms_conv.adb delete mode 100644 main/gcc/ada/vms_conv.ads delete mode 100644 main/gcc/ada/vms_data.ads create mode 100644 main/gcc/ada/vxworks-crtbe-link.spec create mode 100644 main/gcc/ada/vxworks-ppc-link.spec delete mode 100644 main/gcc/ada/xgnatugn.adb create mode 100644 main/gcc/config/moxie/moxiebox.h copy main/gcc/{hash-map.h => hash-set.h} (50%) create mode 100644 main/gcc/inchash.c create mode 100644 main/gcc/inchash.h create mode 100644 main/gcc/rtlhash.c copy main/gcc/{lto/lto-partition.h => rtlhash.h} (52%) create mode 100644 main/gcc/testsuite/c-c++-common/addrtmp.c create mode 100644 main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455-2.c create mode 100644 main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455.c create mode 100644 main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61963.c create mode 100644 main/gcc/testsuite/c-c++-common/ubsan/align-1.c create mode 100644 main/gcc/testsuite/c-c++-common/ubsan/align-2.c create mode 100644 main/gcc/testsuite/c-c++-common/ubsan/align-3.c create mode 100644 main/gcc/testsuite/c-c++-common/ubsan/align-4.c create mode 100644 main/gcc/testsuite/c-c++-common/ubsan/align-5.c create mode 100644 main/gcc/testsuite/c-c++-common/ubsan/attrib-4.c create mode 100644 main/gcc/testsuite/g++.dg/cpp0x/vt-57397-1.C create mode 100644 main/gcc/testsuite/g++.dg/cpp0x/vt-57397-2.C create mode 100644 main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-neg.C create mode 100644 main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-ped-neg.C create mode 100644 main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm.C create mode 100644 main/gcc/testsuite/g++.dg/init/explicit2.C create mode 100644 main/gcc/testsuite/g++.dg/ipa/devirt-34.C create mode 100644 main/gcc/testsuite/g++.dg/other/default10.C create mode 100644 main/gcc/testsuite/g++.dg/other/default9.C create mode 100644 main/gcc/testsuite/g++.dg/tc1/dr217-2.C delete mode 100644 main/gcc/testsuite/g++.dg/template/dtor9a.C create mode 100644 main/gcc/testsuite/g++.dg/template/friend56.C create mode 100644 main/gcc/testsuite/g++.dg/tree-prof/morefunc.C create mode 100644 main/gcc/testsuite/g++.dg/tree-prof/reorder.C create mode 100644 main/gcc/testsuite/g++.dg/tree-prof/reorder_class1.h create mode 100644 main/gcc/testsuite/g++.dg/tree-prof/reorder_class2.h create mode 100644 main/gcc/testsuite/g++.dg/ubsan/align-1.C create mode 100644 main/gcc/testsuite/g++.dg/ubsan/align-2.C create mode 100644 main/gcc/testsuite/g++.dg/ubsan/align-3.C create mode 100644 main/gcc/testsuite/g++.dg/ubsan/attrib-1.C create mode 100644 main/gcc/testsuite/g++.dg/ubsan/null-1.C create mode 100644 main/gcc/testsuite/g++.dg/ubsan/null-2.C create mode 100644 main/gcc/testsuite/g++.dg/warn/Wsuggest-final.C create mode 100644 main/gcc/testsuite/gcc.c-torture/execute/20050316-3.x create mode 100644 main/gcc/testsuite/gcc.c-torture/execute/pr23135.x create mode 100644 main/gcc/testsuite/gcc.dg/Wdesignated-init-2.c create mode 100644 main/gcc/testsuite/gcc.dg/Wdesignated-init.c create mode 100644 main/gcc/testsuite/gcc.dg/case-bogus-1.c create mode 100644 main/gcc/testsuite/gcc.dg/fold-abs-5.c create mode 100644 main/gcc/testsuite/gcc.dg/fold-cstring.c create mode 100644 main/gcc/testsuite/gcc.dg/fold-cvect.c create mode 100644 main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-1.c create mode 100644 main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-2.c create mode 100644 main/gcc/testsuite/gcc.dg/pr61756.c create mode 100644 main/gcc/testsuite/gcc.dg/pr61762.c create mode 100644 main/gcc/testsuite/gcc.dg/pr61861.c create mode 100644 main/gcc/testsuite/gcc.dg/pr61868.c create mode 100644 main/gcc/testsuite/gcc.dg/torture/ftrapv-1.c create mode 100644 main/gcc/testsuite/gcc.dg/torture/pr61964.c create mode 100644 main/gcc/testsuite/gcc.target/aarch64/legitimize_stack_var_before_reload_1.c create mode 100644 main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_f64.c create mode 100644 main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_s64.c create mode 100644 main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_u64.c create mode 100644 main/gcc/testsuite/gcc.target/arm/pr61948.c create mode 100644 main/gcc/testsuite/gcc.target/i386/pr44551-1.c create mode 100644 main/gcc/testsuite/gcc.target/i386/pr61801.c copy main/gcc/testsuite/gcc.target/mips/{const-anchor-1.c => const-anchor-3.c} (67%) copy main/gcc/testsuite/gcc.target/mips/{const-anchor-2.c => const-anchor-4.c} (62%) create mode 100644 main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-1.c create mode 100644 main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-2.c create mode 100644 main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-3.c create mode 100644 main/gcc/testsuite/gcc.target/powerpc/pr60102.c create mode 100644 main/gcc/testsuite/gfortran.dg/pr61921.f90 create mode 100644 main/gcc/testsuite/gfortran.dg/storage_size_5.f90 delete mode 100644 main/gcc/testsuite/gnat.dg/discr6.adb delete mode 100644 main/gcc/testsuite/gnat.dg/discr6_pkg.ads create mode 100644 main/libgomp/testsuite/libgomp.c/depend-10.c create mode 100644 main/libgomp/testsuite/libgomp.c/depend-5.c create mode 100644 main/libgomp/testsuite/libgomp.c/depend-6.c create mode 100644 main/libgomp/testsuite/libgomp.c/depend-7.c create mode 100644 main/libgomp/testsuite/libgomp.c/depend-8.c create mode 100644 main/libgomp/testsuite/libgomp.c/depend-9.c copy main/libstdc++-v3/testsuite/{23_containers/set/debug/move_assign_neg.cc => 20_util/tuple/61947.cc} (60%) create mode 100644 main/libstdc++-v3/testsuite/26_numerics/random/pr60037-neg.cc create mode 100644 main/libstdc++-v3/testsuite/ext/random/hypergeometric_distribution/pr60037.cc copy main/libstdc++-v3/testsuite/{23_containers/set/debug/move_assign_neg.cc => ext/rope/61946.cc} (58%) diff --git a/main/ChangeLog b/main/ChangeLog index aecefa60fdd..917cf57c3eb 100644 --- a/main/ChangeLog +++ b/main/ChangeLog @@ -1,3 +1,22 @@ +2014-08-01 Jiong Wang + + * MAINTAINERS (Write After Approval): Add myself. + +2014-07-28 Anthony Green + + Import from savannah.gnu.org: + * config.sub: Update to 2014-07-28 version. + +2014-07-27 Richard Sandiford + + * MAINTAINERS: Remove my MIPS maintainer entry. + +2014-07-26 Uros Bizjak + + PR target/47230 + * configure.ac (alpha*-*-linux*): Use mh-alpha-linux. + * configure: Regenerate. + 2014-07-24 James Norris * MAINTAINERS (Write After Approval): Add myself. diff --git a/main/MAINTAINERS b/main/MAINTAINERS index 427ba644ce5..87fb9dd1e0d 100644 --- a/main/MAINTAINERS +++ b/main/MAINTAINERS @@ -79,7 +79,6 @@ mcore port Nick Clifton nickc@redhat.com mep port DJ Delorie dj@redhat.com microblaze Michael Eager eager@eagercon.com mips port Eric Christopher echristo@gmail.com -mips port Richard Sandiford rdsandiford@googlemail.com mmix port Hans-Peter Nilsson hp@bitrange.com mn10300 port Jeff Law law@redhat.com mn10300 port Alexandre Oliva aoliva@redhat.com @@ -565,6 +564,7 @@ Kugan Vivekanandarajah kuganv@linaro.org Tom de Vries tom@codesourcery.com Nenad Vukicevic nenad@intrepid.com Feng Wang fengwang@nudt.edu.cn +Jiong Wang jiong.wang@arm.com Stephen M. Webb stephen.webb@bregmasoft.com John Wehle john@feith.com Florian Weimer fw@deneb.enyo.de diff --git a/main/config.sub b/main/config.sub index d654d03cdcd..88a0cb463a8 100755 --- a/main/config.sub +++ b/main/config.sub @@ -2,7 +2,7 @@ # Configuration validation subroutine script. # Copyright 1992-2014 Free Software Foundation, Inc. -timestamp='2014-05-01' +timestamp='2014-07-28' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -828,6 +828,10 @@ case $basic_machine in basic_machine=powerpc-unknown os=-morphos ;; + moxiebox) + basic_machine=moxie-unknown + os=-moxiebox + ;; msdos) basic_machine=i386-pc os=-msdos @@ -1373,7 +1377,7 @@ case $os in | -cygwin* | -msys* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ | -mingw32* | -mingw64* | -linux-gnu* | -linux-android* \ | -linux-newlib* | -linux-musl* | -linux-uclibc* \ - | -uxpv* | -beos* | -mpeix* | -udk* \ + | -uxpv* | -beos* | -mpeix* | -udk* | -moxiebox* \ | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ diff --git a/main/config/ChangeLog b/main/config/ChangeLog index c509972e785..34fe7a664ee 100644 --- a/main/config/ChangeLog +++ b/main/config/ChangeLog @@ -1,14 +1,7 @@ -2014-07-24 Martin Liska - * mips.c (mips_start_unique_function): Correct cgraph_node function - used. - * rs6000.c (call_ABI_of_interest): Likewise. - (rs6000_code_end): Likewise. +2014-07-26 Uros Bizjak -2014-07-24 Martin Liska - - * rs6000.c (rs6000_xcoff_declare_function_name): Correct symtab_node - funtion used. - (rs6000_xcoff_declare_object_name): Likewise. + PR target/47230 + * mh-alpha-linux: New file. 2014-05-14 Sandra Loosemore diff --git a/main/config/mh-alpha-linux b/main/config/mh-alpha-linux new file mode 100644 index 00000000000..9a9244baaa3 --- /dev/null +++ b/main/config/mh-alpha-linux @@ -0,0 +1,3 @@ +# Prevent GPREL16 relocation truncation +LDFLAGS += -Wl,--no-relax +BOOT_LDFLAGS += -Wl,--no-relax diff --git a/main/configure b/main/configure index 0563aa5b516..940047f17b0 100755 --- a/main/configure +++ b/main/configure @@ -3881,6 +3881,9 @@ fi *-mingw*) host_makefile_frag="config/mh-mingw" ;; + alpha*-*-linux*) + host_makefile_frag="config/mh-alpha-linux" + ;; hppa*-hp-hpux10*) host_makefile_frag="config/mh-pa-hpux10" ;; diff --git a/main/configure.ac b/main/configure.ac index ccd3af3e6fb..430f21c0dab 100644 --- a/main/configure.ac +++ b/main/configure.ac @@ -1180,6 +1180,9 @@ case "${host}" in *-mingw*) host_makefile_frag="config/mh-mingw" ;; + alpha*-*-linux*) + host_makefile_frag="config/mh-alpha-linux" + ;; hppa*-hp-hpux10*) host_makefile_frag="config/mh-pa-hpux10" ;; diff --git a/main/contrib/mklog b/main/contrib/mklog index cdc64551d5f..3d17dc54891 100755 --- a/main/contrib/mklog +++ b/main/contrib/mklog @@ -30,16 +30,15 @@ $username = $ENV{'USER'}; $name = `finger $username | grep -o 'Name: .*'`; @n = split(/: /, $name); -$name = @n[1]; chop($name); +$name = $n[1]; chop($name); $addr = $username . "\@my.domain.org"; $date = `date +%Y-%m-%d`; chop ($date); $gcc_root = $0; $gcc_root =~ s/[^\\\/]+$/../; -chdir $gcc_root; # if this is a git tree then take name and email from the git configuration -if (-d .git) { +if (-d "$gcc_root/.git") { $gitname = `git config user.name`; chomp($gitname); if ($gitname) { @@ -80,7 +79,7 @@ sub get_clname ($) { my $dirname = $_[0]; while ($dirname) { my $clname = "$dirname/ChangeLog"; - if (-f $clname) { + if (-f "$gcc_root/$clname") { my $relname = substr ($_[0], length ($dirname) + 1); return ($clname, $relname); } else { diff --git a/main/gcc/ChangeLog b/main/gcc/ChangeLog index 1e827b573e3..e058622c54c 100644 --- a/main/gcc/ChangeLog +++ b/main/gcc/ChangeLog @@ -1,3 +1,843 @@ +2014-08-04 Rohit + + PR target/60102 + * config/rs6000/rs6000.c + (rs6000_reg_names) : Add SPE high register names. + (alt_reg_names) : Likewise. + (rs6000_dwarf_register_span) : For SPE high registers, replace + dwarf register numbers with GCC hard register numbers. + (rs6000_init_dwarf_reg_sizes_extra) : Likewise. + (rs6000_dbx_register_number): For SPE high registers, return dwarf + register number for the corresponding GCC hard register number. + * config/rs6000/rs6000.h + (FIRST_PSEUDO_REGISTER) : Update based on 32 newly added GCC hard + register numbers for SPE high registers. + (DWARF_FRAME_REGISTERS) : Likewise. + (DWARF_REG_TO_UNWIND_COLUMN) : Likewise. + (DWARF_FRAME_REGNUM) : Likewise. + (FIXED_REGISTERS) : Likewise. + (CALL_USED_REGISTERS) : Likewise. + (CALL_REALLY_USED_REGISTERS) : Likewise. + (REG_ALLOC_ORDER) : Likewise. + (enum reg_class) : Likewise. + (REG_CLASS_NAMES) : Likewise. + (REG_CLASS_CONTENTS) : Likewise. + (SPE_HIGH_REGNO_P) : New macro to identify SPE high registers. + * gcc.target/powerpc/pr60102.c: New testcase. + +2014-08-04 Richard Biener + + * gimple-fold.h (gimple_fold_builtin): Remove. + * gimple-fold.c (gimple_fold_builtin): Make static. + * tree-ssa-ccp.c (pass_fold_builtins::execute): Use + fold_stmt, not gimple_fold_builtin. + +2014-08-04 Martin Liska + + * cgraph.h (csi_end_p): Removed. + (csi_next): Likewise. + (csi_node): Likewise. + (csi_start): Likewise. + (cgraph_node_in_set_p): Likewise. + (cgraph_node_set_size): Likewise. + (vsi_end_p): Likewise. + (vsi_next): Likewise. + (vsi_node): Likewise. + (vsi_start): Likewise. + (varpool_node_set_size): Likewise. + (cgraph_node_set_nonempty_p): Likewise. + (varpool_node_set_nonempty_p): Likewise. + * cgraphunit.c (cgraph_process_new_functions): vec replaces + cgraph_node_set. + * ipa-inline-transform.c: Likewise. + * ipa-utils.c (cgraph_node_set_new): Removed. + (cgraph_node_set_add): Likewise. + (cgraph_node_set_remove): Likewise. + (cgraph_node_set_find): Likewise. + (dump_cgraph_node_set): Likewise. + (debug_cgraph_node_set): Likewise. + (free_cgraph_node_set): Likewise. + (varpool_node_set_new): Likewise. + (varpool_node_set_add): Likewise. + (varpool_node_set_remove): Likewise. + (varpool_node_set_find): Likewise. + (dump_varpool_node_set): Likewise. + (free_varpool_node_set): Likewise. + (debug_varpool_node_set): Likewise. + * tree-emutls.c (struct tls_var_data): + (emutls_index): Removed. + (emutls_decl): Likewise. + (gen_emutls_addr): Function implementation uses newly added + hash_map. + (clear_access_vars): Likewise. + (create_emultls_var): Likewise. + (ipa_lower_emutls): Likewise. + (reset_access): New function. + +2014-08-04 Ganesh Gopalasubramanian + + * config/i386/i386.c (ix86_option_override_internal): Add + PTA_RDRND and PTA_MOVBE for bdver4. + +2014-08-04 Kyrylo Tkachov + James Greenhalgh + + * doc/md.texi (clrsb): Document. + (clz): Change reference to x into operand 1. + (ctz): Likewise. + (popcount): Likewise. + +2014-08-04 Kyrylo Tkachov + + PR target/61713 + * gcc/optabs.c (expand_atomic_test_and_set): Do not try to emit + move to subtarget in serial version if result is ignored. + +2014-08-04 Ramana Radhakrishnan + Kyrylo Tkachov + + * sched-deps.c (try_group_insn): Generalise macro fusion hook usage + to any two insns. Update comment. Rename to sched_macro_fuse_insns. + (sched_analyze_insn): Update use of try_group_insn to + sched_macro_fuse_insns. + * config/i386/i386.c (ix86_macro_fusion_pair_p): Reject 2nd + arguments that are not conditional jumps. + +2014-08-04 Ganesh Gopalasubramanian + + * config/i386/driver-i386.c (host_detect_local_cpu): Handle AMD's extended + family information. Handle BTVER2 cpu with cpuid family value. + +2014-08-04 Tom de Vries + + * doc/sourcebuild.texi (glibc, glibc_2_12_or_later) + (glibc_2_11_or_earlier): Document effective-target keywords. + +2014-08-01 Jan Hubicka + + * ipa-devirt.c (odr_type_warn_count): Add type. + (possible_polymorphic_call_targets): Set it. + (ipa_devirt): Use it. + +2014-08-01 Jan Hubicka + + * doc/invoke.texi (Wsuggest-final-types, Wsuggest-final-methods): Document. + * ipa-devirt.c: Include hash-map.h + (struct polymorphic_call_target_d): Add type_warning and decl_warning. + (clear_speculation): Break out of ... + (get_class_context): ... here; speed up handling obviously useless + speculations. + (odr_type_warn_count, decl_warn_count): New structures. + (final_warning_record): New structure. + (final_warning_records): New static variable. + (possible_polymorphic_call_targets): Cleanup handling of speculative info; + do not build speculation when user do not care; record info about warnings + when asked for. + (add_decl_warning): New function. + (type_warning_cmp): New function. + (decl_warning_cmp): New function. + (ipa_devirt): Handle -Wsuggest-final-methods and -Wsuggest-final-types. + (gate): Enable pass when warnings are requested. + * common.opt (Wsuggest-final-types, Wsuggest-final-methods): New options. + +2014-08-02 Trevor Saunders + + * hash-map.h (default_hashmap_traits::mark_key_deleted): + Fix cast. + (hash_map::remove): New method. + (hash_map::traverse): New method. + * cgraph.h, except.c, except.h, gimple-ssa-strength-reduction.c, + ipa-utils.c, lto-cgraph.c, lto-streamer.h, omp-low.c, predict.c, + tree-cfg.c, tree-cfgcleanup.c, tree-eh.c, tree-eh.h, tree-inline.c, + tree-inline.h, tree-nested.c, tree-sra.c, tree-ssa-loop-im.c, + tree-ssa-loop-ivopts.c, tree-ssa-reassoc.c, tree-ssa-structalias.c, + tree-ssa.c, tree-ssa.h, var-tracking.c: Use hash_map instead of + pointer_map. + +2014-08-02 Trevor Saunders + + * hash-set.h: new File. + * cfgexpand.c, cfgloop.c, cgraph.c, cgraphbuild.c, cgraphunit.c, + cprop.c, cse.c, gimple-walk.c, gimple-walk.h, gimplify.c, godump.c, + ipa-devirt.c, ipa-pure-const.c, ipa-visibility.c, ipa.c, lto-cgraph.c, + lto-streamer-out.c, stmt.c, tree-cfg.c, tree-core.h, tree-eh.c, + tree-inline.c, tree-inline.h, tree-nested.c, tree-pretty-print.c, + tree-ssa-loop-niter.c, tree-ssa-phiopt.c, tree-ssa-threadedge.c, + tree-ssa-uninit.c, tree.c, tree.h, value-prof.c, varasm.c, + varpool.c: Use hash_set instead of pointer_set. + +2014-08-01 Alan Lawrence + + * config/aarch64/aarch64-simd-builtins.def (dup_lane, get_lane): Delete. + +2014-08-01 Jiong Wang + + * config/aarch64/aarch64.c (aarch64_classify_address): Accept all offset + for frame access when strict_p is false. + +2014-08-01 Renlin Li +2014-08-01 Jiong Wang + + * config/aarch64/aarch64.c (offset_7bit_signed_scaled_p): Rename to + aarch64_offset_7bit_signed_scaled_p, remove static and use it. + * config/aarch64/aarch64-protos.h (aarch64_offset_7bit_signed_scaled_p): + Declaration. + * config/aarch64/predicates.md (aarch64_mem_pair_offset): Define new + predicate. + * config/aarch64/aarch64.md (loadwb_pair, storewb_pair): Use + aarch64_mem_pair_offset. + +2014-08-01 Jiong Wang + + * config/aarch64/aarch64.md (loadwb_pair_): Fix + offset. + (loadwb_pair_): Likewise. + * config/aarch64/aarch64.c (aarch64_gen_loadwb_pair): Likewise. + +2014-08-01 Matthew Fortune + + * config/mips/mips.h (REGISTER_PREFIX): Define macro. + +2014-08-01 James Greenhalgh + + PR regression/61510 + * cgraphunit.c (analyze_functions): Use get_create rather than get + for decls which are clones of abstract functions. + +2014-08-01 Martin Liska + + * gimple-iterator.h (gsi_next_nonvirtual_phi): New function. + * ipa-prop.h (count_formal_params): Global function created from static. + * ipa-prop.c (count_formal_params): Likewise. + * ipa-utils.c (ipa_merge_profiles): Be more tolerant if we merge + profiles for semantically equivalent functions. + * passes.c (do_per_function): If we load body of a function + during WPA, this condition should behave same. + * varpool.c (ctor_for_folding): More tolerant assert for variable + aliases created during WPA. + +2014-08-01 Martin Liska + + * doc/invoke.texi (Options That Control Optimization): Documentation + for -foptimize-strlen introduced. Optimization levels default options + fixed. + +2014-08-01 Jakub Jelinek + + * opts.c (common_handle_option): Handle -fsanitize=alignment. + * ubsan.h (enum ubsan_null_ckind): Add UBSAN_CTOR_CALL. + (ubsan_expand_bounds_ifn, ubsan_expand_null_ifn): Change return + type to bool. + * stor-layout.h (min_align_of_type): New prototype. + * asan.c (pass_sanopt::execute): Don't perform gsi_next if + ubsan_expand* told us not to do it. Remove the extra gsi_end_p + check. + * ubsan.c: Include builtins.h. + (ubsan_expand_bounds_ifn): Change return type to bool, + always return true. + (ubsan_expand_null_ifn): Change return type to bool, change + argument to gimple_stmt_iterator *. Handle both null and alignment + sanitization, take type from ckind argument's type rather than + first argument. + (instrument_member_call): Removed. + (instrument_mem_ref): Remove t argument, add mem and base arguments. + Handle both null and alignment sanitization, don't say whole + struct access is member access. Build 3 argument IFN_UBSAN_NULL + call instead of 2 argument. + (instrument_null): Adjust instrument_mem_ref caller. Don't + instrument calls here. + (pass_ubsan::gate, pass_ubsan::execute): Handle SANITIZE_ALIGNMENT + like SANITIZE_NULL. + * stor-layout.c (min_align_of_type): New function. + * flag-types.h (enum sanitize_code): Add SANITIZE_ALIGNMENT. + Or it into SANITIZE_UNDEFINED. + * doc/invoke.texi (-fsanitize=alignment): Document. + +2014-07-31 Andi Kleen + + * tree-ssa-tail-merge.c (same_succ_hash): Convert to inchash. + +2014-07-31 Andi Kleen + + * tree-ssa-sccvn.c (vn_reference_op_compute_hash): Convert to + inchash. + (vn_reference_compute_hash): Dito. + (vn_nary_op_compute_hash): Dito. + (vn_phi_compute_hash): Dito. + * tree-ssa-sccvn.h (vn_hash_constant_with_type): Dito. + +2014-07-31 Andi Kleen + + * tree-ssa-dom.c (iterative_hash_exprs_commutative): + Rename to inchash:add_expr_commutative. Convert to inchash. + (iterative_hash_hashable_expr): Rename to + inchash:add_hashable_expr. Convert to inchash. + (avail_expr_hash): Dito. + +2014-07-31 Andi Kleen + + * ipa-devirt.c (polymorphic_call_target_hasher::hash): + Convert to inchash. + +2014-07-31 Andi Kleen + + * asan.c (asan_mem_ref_hasher::hash): Convert to inchash. + +2014-07-31 Andi Kleen + + * Makefile.in (OBJS): Add rtlhash.o + * dwarf2out.c (addr_table_entry_do_hash): Convert to inchash. + (loc_checksum): Dito. + (loc_checksum_ordered): Dito. + (hash_loc_operands): Dito. + (hash_locs): Dito. + (hash_loc_list): Dito. + * rtl.c (iterative_hash_rtx): Moved to rtlhash.c + * rtl.h (iterative_hash_rtx): Moved to rtlhash.h + * rtlhash.c: New file. + * rtlhash.h: New file. + +2014-07-31 Andi Kleen + + * inchash.h (inchash): Change inchash class to namespace. + (class hash): ... Rename from inchash. + (add_object): Move from macro to class template. + * lto-streamer-out.c (hash_tree): Change inchash + to inchash::hash. + * tree.c (build_type_attribute_qual_variant): Dito. + (type_hash_list): Dito. + (attribute_hash_list): Dito. + (iterative_hstate_expr): Rename to inchash::add_expr + (build_range_type_1): Change inchash to inchash::hash + and use hash::add_expr. + (build_array_type_1): Dito. + (build_function_type): Dito + (build_method_type_directly): Dito. + (build_offset_type): Dito. + (build_complex_type): Dito. + (make_vector_type): Dito. + * tree.h (iterative_hash_expr): Dito. + +2014-07-31 Chen Gang + + * gcc.c (do_spec_1): Allocate enough space for saved_suffix. + +2014-07-31 James Greenhalgh + + * config/aarch64/arm_neon.h (vpadd_<8,16,32,64>): Move to + correct alphabetical position. + (vpaddd_f64): Rewrite using builtins. + (vpaddd_s64): Move to correct alphabetical position. + (vpaddd_u64): New. + +2014-07-31 Oleg Endo + + PR target/61844 + * config/sh/sh.c (sh_legitimate_address_p, + sh_legitimize_reload_address): Handle reg+reg address modes when + ALLOW_INDEXED_ADDRESS is false. + * config/sh/predicates.md (general_movsrc_operand, + general_movdst_operand): Likewise. + +2014-07-31 James Greenhalgh + + * config/aarch64/aarch64-builtins.c + (aarch64_gimple_fold_builtin): Don't fold reduction operations for + BYTES_BIG_ENDIAN. + +2014-07-31 James Greenhalgh + + * config/aarch64/aarch64.c (aarch64_simd_vect_par_cnst_half): Vary + the generated mask based on BYTES_BIG_ENDIAN. + (aarch64_simd_check_vect_par_cnst_half): New. + * config/aarch64/aarch64-protos.h + (aarch64_simd_check_vect_par_cnst_half): New. + * config/aarch64/predicates.md (vect_par_cnst_hi_half): Refactor + the check out to aarch64_simd_check_vect_par_cnst_half. + (vect_par_cnst_lo_half): Likewise. + * config/aarch64/aarch64-simd.md + (aarch64_simd_move_hi_quad_): Always use vec_par_cnst_lo_half. + (move_hi_quad_): Always generate a low mask. + +2014-07-30 Senthil Kumar Selvaraj + + * doc/invoke.texi (AVR Options): Add documentation about + __AVR_DEVICE_NAME__ built-in macro. + +2014-07-31 Charles Baylis + + PR target/61948 + * config/arm/neon.md (ashldi3_neon): Don't emit arm_ashldi3_1bit unless + constraints are satisfied. + (di3_neon): Likewise. + +2014-07-31 Richard Biener + + PR tree-optimization/61964 + * tree-ssa-tail-merge.c (gimple_equal_p): Handle non-SSA LHS solely + by structural equality. + +2014-07-31 Yury Gribov + + * doc/cpp.texi (__SANITIZE_ADDRESS__): Updated description. + * doc/invoke.texi (-fsanitize=kernel-address): Describe new option. + * flag-types.h (SANITIZE_USER_ADDRESS, SANITIZE_KERNEL_ADDRESS): + New enums. + * gcc.c (sanitize_spec_function): Support new option. + (SANITIZER_SPEC): Remove now redundant check. + * opts.c (common_handle_option): Support new option. + (finish_options): Check for incompatibilities. + * toplev.c (process_options): Split userspace-specific checks. + +2014-07-31 Richard Biener + + * lto-streamer.h (struct output_block): Remove global. + (struct data_in): Remove labels, num_named_labels and + num_unnamed_labels. + * lto-streamer-in.c (lto_data_in_delete): Do not free labels. + * lto-streamer-out.c (produce_asm_for_decls): Do not set global. + +2014-07-31 Marc Glisse + + PR c++/60517 + * common.opt (-Wreturn-local-addr): Moved from c.opt. + * gimple-ssa-isolate-paths.c: Include diagnostic-core.h and intl.h. + (isolate_path): New argument to avoid inserting a trap. + (find_implicit_erroneous_behaviour): Handle returning the address + of a local variable. + (find_explicit_erroneous_behaviour): Likewise. + +2014-07-31 Bingfeng Mei + + PR lto/61868 + * toplev.c (init_random_seed): Move piece of code never called to + set_random_seed. + (set_random_seed): see above. + +2014-07-31 Tom de Vries + + * tree-ssa-loop.c (pass_tree_loop_init::execute): Remove dead code. + +2014-07-31 Richard Sandiford + + * ira.c (insn_contains_asm_1, insn_contains_asm): Delete. + (compute_regs_asm_clobbered): Use extract_asm_operands instead. + +2014-07-31 Richard Biener + + * data-streamer.h (streamer_write_data_stream): Declare here, + renamed from ... + * lto-streamer.h (lto_output_data_stream): ... this. Remove. + * lto-cgraph.c (lto_output_node): Adjust. + (lto_output_varpool_node): Likewise. + * data-streamer-out.c (streamer_string_index): Likewise. + (streamer_write_data_stream, lto_append_block): Move from ... + * lto-section-out.c (lto_output_data_stream, + lto_append_block): ... here. + +2014-07-30 Mike Stump + + * configure.ac: Also check for popen. + * tree-loop-distribution.c (dot_rdg): Autoconfize popen use. + * configure: Regenerate. + * config.in: Regenerate. + +2014-07-30 Martin Jambor + + * tree-sra.c (sra_ipa_modify_assign): Change type of the first + parameter to gimple. + +2014-07-30 Ulrich Weigand + + * config/s390/s390.c (s390_emit_tpf_eh_return): Pass original return + address as second parameter to __tpf_eh_return routine. + +2014-07-30 Jiong Wang + + * config/arm/arm.c (arm_get_frame_offsets): Adjust condition for + Thumb2. + +2014-07-30 Tom Tromey + + PR c/59855 + * doc/invoke.texi (Warning Options): Document -Wdesignated-init. + * doc/extend.texi (Type Attributes): Document designated_init + attribute. + +2014-07-30 Roman Gareev + + * graphite-isl-ast-to-gimple.c: + (gcc_expression_from_isl_ast_expr_id): Add calling of fold_convert. + (gcc_expression_from_isl_expression): Pass type to + gcc_expression_from_isl_ast_expr_id. + +2014-07-30 Richard Biener + + * lto-streamer.h (lto_write_data): New function. + * langhooks.c (lhd_append_data): Do not free block. + * lto-section-out.c (lto_write_data): New function writing + raw data to the current section. + (lto_write_stream): Adjust for langhook semantic change. + (lto_destroy_simple_output_block): Write header directly. + * lto-opts.c (lto_write_options): Write options directly. + * lto-streamer-out.c (produce_asm): Write heaeder directly. + (lto_output_toplevel_asms): Likewise. + (copy_function_or_variable): Copy data directly. + (write_global_references): Output index table directly. + (lto_output_decl_state_refs): Likewise. + (write_symbol): Write data directly. + (produce_symtab): Adjust. + (produce_asm_for_decls): Output header and refs directly. + +2014-07-29 Jan Hubicka + + * ipa-devirt.c (polymorphic_call_target_d): Rename nonconstruction_targets + to speculative_targets + (get_class_context): Fix handling of contextes without outer type; + avoid matching non-polymorphic types in LTO. + (possible_polymorphic_call_targets): Trun nonconstruction_targetsp + parameter to speculative_targetsp; handle speculation. + (dump_possible_polymorphic_call_targets): Update dumping. + +2014-07-29 Jan Hubicka + + * common.opt (Wodr): Enable by default. + +2014-07-29 Olivier Hainque + + * config/vxworksae.h (VXWORKS_OVERRIDE_OPTIONS): Define. + +2014-07-29 H.J. Lu + + PR bootstrap/61914 + * gengtype.c (strtoken): New function. + (create_user_defined_type): Replace strtok with strtoken. + +2014-07-29 Nathan Sidwell + + * gcov-io.c (gcov_var): Make hidden. + * gcov-tool.c (gcov_list, gcov_exit): Remove declarations. + (gcov_do_dump): Declare. + (gcov_output_files): Call gcov_do_dump, not gcov_exit). + +2014-07-29 Martin Jambor + + * tree-sra.c (sra_modify_constructor_assign): Change type of stmt + parameter to gimple. + (sra_modify_assign): Likewise. + +2014-07-29 Richard Biener + + PR middle-end/52478 + * expr.c (expand_expr_real_2): Revert last change. + +2014-07-28 Jan Hubicka + + * cgraph.c (cgraph_node::create_indirect_edge): Copy speculative data. + * cgraph.h (cgraph_indirect_call_info): Add speculative data. + * gimple-fold.c (fold_gimple_assign): Fix check for virtual + call. + * ipa-devirt.c (ipa_dummy_polymorphic_call_context): Update + (contains_type_p): Forward declare. + (polymorphic_call_target_hasher::hash): Hash speculative info. + (polymorphic_call_target_hasher::equal): Compare speculative info. + (get_class_context): Handle speuclation. + (contains_type_p): Update. + (get_polymorphic_call_info_for_decl): Update. + (walk_ssa_copies): Break out from ... + (get_polymorphic_call_info): ... here; set speculative context + before giving up. + * ipa-prop.c (ipa_write_indirect_edge_info, + ipa_read_indirect_edge_info): Stream speculative context. + * ipa-utils.h (ipa_polymorphic_call_context): Add speculative info + (SPECULATIVE_OFFSET, SPECULATIVE_OUTER_TYPE, + SPECULATIVE_MAYBE_DERIVED_TYPE). + (possible_polymorphic_call_targets overriders): Update. + (dump_possible_polymorphic_call_targets overriders): Update. + (dump_possible_polymorphic_call_target_p overriders): Update. + +2014-07-28 Jan Hubicka + + * gimple-fold.c (fold_gimple_assign): Fix condition guarding + ipa-devirt path; fix thinko there. + +2014-07-28 Trevor Saunders + + * config/i386/i386.c (ix86_return_in_memory): Replace one + ATTRIBUTE_UNUSED where the attribute can actually sometimes be unused. + +2014-07-28 Marek Polacek + + * doc/invoke.texi (-Wno-odr): Fix @item entry. Tweak wording. + +2014-07-28 Peter Bergner + + * config.gcc (powerpc*-*-linux*): Include gnu-user.h in tm_file. + * config/rs6000/sysv4.h (CC1_SPEC): Undefine it before defining it. + * config/rs6000/linux.h (CPLUSPLUS_CPP_SPEC): Delete define. + (LINK_GCC_C_SEQUENCE_SPEC): Likewise. + (USE_LD_AS_NEEDED): Likewise. + (ASM_APP_ON): Likewise. + (ASM_APP_OFF): Likewise. + (TARGET_POSIX_IO): Likewise. + * config/rs6000/linux64.h (CPLUSPLUS_CPP_SPEC): Likewise. + (LINK_GCC_C_SEQUENCE_SPEC): Likewise. + (USE_LD_AS_NEEDED): Likewise. + (ASM_APP_ON): Likewise. + (ASM_APP_OFF): Likewise. + (TARGET_POSIX_IO): Likewise. + +2014-07-28 Eric Botcazou + + PR middle-end/61734 + * fold-const.c (fold_comparison): Disable X - Y CMP 0 to X CMP Y for + operators other than the equality operators. + +2014-07-28 Richard Biener + + PR middle-end/52478 + * optabs.c (gen_int_libfunc): For -ftrapv libfuncs make + sure to register SImode ones, not only >= word_mode ones. + * expr.c (expand_expr_real_2): When expanding -ftrapv + binops do not use OPTAB_LIB_WIDEN. + +2014-07-28 Richard Sandiford + + PR middle-end/61919 + * tree-outof-ssa.c (insert_partition_copy_on_edge) + (insert_value_copy_on_edge, insert_rtx_to_part_on_edge) + (insert_part_to_rtx_on_edge): Copy partition_to_pseudo rtxes before + inserting them in the insn stream. + +2014-07-28 Marek Polacek + + PR middle-end/61913 + * common.opt (Wodr): Add Var. + +2014-07-28 Richard Biener + + PR tree-optimization/61921 + * tree-ssa-structalias.c (create_variable_info_for_1): Check + if there is a varpool node before dereferencing it. + +2014-07-28 Roman Gareev + + * graphite-sese-to-poly.c: + (new_pbb_from_pbb): Set a new id of pbb1->domain (instead of using the + id of the pbb), which contains pointer to the pbb1. + + * gcc.dg/graphite/isl-ast-gen-if-2.c: New testcase. + +2014-07-28 Roman Gareev + + * graphite-isl-ast-to-gimple.c: + (graphite_create_new_guard): New function. + (translate_isl_ast_node_if): New function. + (translate_isl_ast): Add calling of translate_isl_ast_node_if. + + * gcc.dg/graphite/isl-ast-gen-if-1.c: New testcase. + +2014-07-27 Anthony Green + + * config.gcc: Add moxie-*-moxiebox* configuration. + * config/moxie/moxiebox.h: New file. + +2014-07-26 Andrew Pinski + + * config/aarch64/aarch64.md (*extr_insv_lower_reg): Remove + + from the read only register. + +2014-07-26 Richard Sandiford + + * ira-costs.c (find_costs_and_classes): For -O0, use the best class + as the allocation class if it isn't likely to be spilled. + +2014-07-26 Richard Sandiford + + * rtl.h (tls_referenced_p): Declare. + * rtlanal.c (tls_referenced_p_1, tls_referenced_p): New functions. + * config/mips/mips.c (mips_tls_symbol_ref_1): Delete. + (mips_cannot_force_const_mem): Use tls_referenced_p. + * config/pa/pa-protos.h (pa_tls_referenced_p): Delete. + * config/pa/pa.h (CONSTANT_ADDRESS_P): Use tls_referenced_p + instead of pa_tls_referenced_p. + * config/pa/pa.c (hppa_legitimize_address, pa_cannot_force_const_mem) + (pa_emit_move_sequence, pa_emit_move_sequence): Likewise. + (pa_legitimate_constant_p): Likewise. + (pa_tls_symbol_ref_1, pa_tls_referenced_p): Delete. + * config/rs6000/rs6000.c (rs6000_tls_referenced_p): Delete. + (rs6000_cannot_force_const_mem, rs6000_emit_move) + (rs6000_address_for_altivec): Use tls_referenced_p instead of + rs6000_tls_referenced_p. + (rs6000_tls_symbol_ref_1): Delete. + +2014-07-26 Marc Glisse + + PR target/44551 + * simplify-rtx.c (simplify_binary_operation_1) : + Optimize inverse of a VEC_CONCAT. + +2014-07-25 Xinliang David Li + + * params.def: New parameter. + * coverage.c (get_coverage_counts): Check new flag. + (coverage_compute_profile_id): Check new flag. + (coverage_begin_function): Check new flag. + (coverage_end_function): Check new flag. + * value-prof.c (coverage_node_map_initialized_p): New function. + (init_node_map): Populate map with all functions. + * doc/invoke.texi: Document new parameter. + +2014-07-25 Jan Hubicka + Richard Biener + + * lto-streamer-out.c (struct sccs): Turn to ... + (class DFS): ... this one; refactor the DFS walk so it can + be re-done on per-SCC basis. + (DFS::DFS): New constructor. + (DFS::~DFS): New destructor. + (hash_tree): Add new MAP argument holding in-SCC hash values; + remove POINTER_TYPE hashing hack. + (scc_entry_compare): Rename to ... + (DFS::scc_entry_compare): ... this one. + (hash_scc): Rename to ... + (DFS::hash_scc): ... this one; pass output_block instead + of streamer_cache; work harder to get unique and stable SCC + hashes. + (DFS_write_tree): Rename to ... + (DFS::DFS_write_tree): ... this one; add SINGLE_P parameter. + (lto_output_tree): Update. + +2014-07-25 Andi Kleen + + * lto-streamer-out.c (hash_tree): Convert to inchash. + +2014-07-25 Andi Kleen + + * tree.c (build_type_attribute_qual_variant): Use inchash. + (type_hash_list): Dito. + (attribute_hash_list): Dito + (iterative_hstate_expr): Dito. + (iterative_hash_expr): Dito. + (build_range_type_1): Dito. + (build_array_type_1): Dito. + (build_function_type): Dito. + (build_method_type_directly): Dito. + (build_offset_type): Dito. + (build_complex_type): Dito. + (make_vector_type): Dito. + * tree.h (iterative_hash_expr): Add compat wrapper. + (iterative_hstate_expr): Add. + +2014-07-25 Andi Kleen + + * Makefile.in (OBJS): Add inchash.o. + (PLUGIN_HEADERS): Add inchash.h. + * ipa-devirt.c: Include inchash.h. + * lto-streamer-out.c: Dito. + * tree-ssa-dom.c: Dito. + * tree-ssa-pre.c: Dito. + * tree-ssa-sccvn.c: Dito. + * tree-ssa-tail-merge.c: Dito. + * asan.c: Dito. + * tree.c (iterative_hash_hashval_t): Move to ... + (iterative_hash_host_wide_int): Move to ... + * inchash.c: Here. New file. + * tree.h (iterative_hash_hashval_t): Move to ... + (iterative_hash_host_wide_int): Move to ... + * inchash.h: Here. New file. + +2014-07-25 Richard Biener + + PR middle-end/61762 + PR middle-end/61894 + * fold-const.c (native_encode_int): Add and handle offset + parameter to do partial encodings of expr. + (native_encode_fixed): Likewise. + (native_encode_real): Likewise. + (native_encode_complex): Likewise. + (native_encode_vector): Likewise. + (native_encode_string): Likewise. + (native_encode_expr): Likewise. + * fold-const.c (native_encode_expr): Add offset parameter + defaulting to -1. + * gimple-fold.c (fold_string_cst_ctor_reference): Remove. + (fold_ctor_reference): Handle all reads from tcc_constant + ctors. + +2014-07-25 Richard Biener + + * tree-inline.c (estimate_move_cost): Mark speed_p argument + as possibly unused. + +2014-07-23 Senthil Kumar Selvaraj + + * config/avr/avr-c.c (avr_cpu_cpp_builtins): Add __AVR_DEVICE_NAME__. + +2014-07-24 Kyle McMartin + + * config/aarch64/aarch64-linux.h (TARGET_ASM_FILE_END): Define. + +2014-07-24 Ulrich Weigand + + * config/rs6000/rs6000-protos.h (rs6000_special_adjust_field_align_p): + Add prototype. + * config/rs6000/rs6000.c (rs6000_special_adjust_field_align_p): New + function. + * config/rs6000/sysv4.h (ADJUST_FIELD_ALIGN): Call it. + * config/rs6000/linux64.h (ADJUST_FIELD_ALIGN): Likewise. + * config/rs6000/freebsd64.h (ADJUST_FIELD_ALIGN): Likewise. + +2014-07-24 Ulrich Weigand + + * config/rs6000/rs6000.c (rs6000_function_arg_boundary): In the AIX + and ELFv2 ABI, do not use the "mode == BLKmode" check to test for + aggregate types. Instead, *all* aggregate types, except for single- + element or homogeneous float/vector aggregates, are quadword-aligned + if required by their type alignment. Issue -Wpsabi note when a type + is now treated differently than before. + +2014-07-24 Ulrich Weigand + + * config/rs6000/rs6000.c (rs6000_function_arg): If a float argument + does not fit fully into floating-point registers, and there is still + space in the register parameter area, use GPRs to pass those parts + of the argument. Issue -Wpsabi note if any parameter is now treated + differently than before. + (rs6000_arg_partial_bytes): Update. + +2014-07-24 Uros Bizjak + + * config/alpha/elf.h: Define TARGET_UNWIND_TABLES_DEFAULT. + +2014-07-24 Richard Sandiford + + * rtl.h (target_rtl): Remove lang_dependent_initialized. + * toplev.c (initialize_rtl): Don't use it. Move previously + "language-dependent" calls to... + (backend_init): ...here. + (lang_dependent_init_target): Don't set lang_dependent_initialized. + Assert that RTL initialization hasn't happend yet. + +2014-07-24 Richard Sandiford + + PR rtl-optimization/61629 + * reginfo.c (reinit_regs): Only call ira_init and recog_init if + they have already been initialized. + +2014-07-24 Richard Sandiford + + PR middle-end/61268 + * function.c (assign_parm_setup_reg): Prevent invalid sharing of + DECL_INCOMING_RTL and entry_parm. + (get_arg_pointer_save_area): Likewise arg_pointer_save_area. + * calls.c (load_register_parameters): Likewise argument values. + (emit_library_call_value_1, store_one_arg): Likewise argument + save areas. + * config/i386/i386.c (assign_386_stack_local): Likewise the local + stack slot. + * explow.c (validize_mem): Modify the argument in-place. + 2014-07-24 Jiong Wang * config/aarch64/aarch64.c (aarch64_popwb_single_reg): New function. @@ -29,6 +869,18 @@ * gcc.dg/graphite/isl-ast-gen-blocks-4.c: New testcase. 2014-07-24 Martin Liska + * config/mips/mips.c (mips_start_unique_function): Correct cgraph_node + function used. + * config/rs6000/rs6000.c (call_ABI_of_interest): Likewise. + (rs6000_code_end): Likewise. + +2014-07-24 Martin Liska + + * config/rs6000/rs6000.c (rs6000_xcoff_declare_function_name): Correct + symtab_node funtion used. + (rs6000_xcoff_declare_object_name): Likewise. + +2014-07-24 Martin Liska * cgraphunit.c (compile): Correct function used. diff --git a/main/gcc/DATESTAMP b/main/gcc/DATESTAMP index 0a40613800d..9c2575bb2b3 100644 --- a/main/gcc/DATESTAMP +++ b/main/gcc/DATESTAMP @@ -1 +1 @@ -20140724 +20140804 diff --git a/main/gcc/Makefile.in b/main/gcc/Makefile.in index 027a7c0d5ae..f5b7b4c441c 100644 --- a/main/gcc/Makefile.in +++ b/main/gcc/Makefile.in @@ -1270,6 +1270,7 @@ OBJS = \ hwint.o \ ifcvt.o \ ree.o \ + inchash.o \ incpath.o \ init-regs.o \ internal-fn.o \ @@ -1352,6 +1353,7 @@ OBJS = \ resource.o \ rtl-error.o \ rtl.o \ + rtlhash.o \ rtlanal.o \ rtlhooks.o \ sbitmap.o \ @@ -3169,7 +3171,7 @@ PLUGIN_HEADERS = $(TREE_H) $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \ tree-parloops.h tree-ssa-address.h tree-ssa-coalesce.h tree-ssa-dom.h \ tree-ssa-loop.h tree-ssa-loop-ivopts.h tree-ssa-loop-manip.h \ tree-ssa-loop-niter.h tree-ssa-ter.h tree-ssa-threadedge.h \ - tree-ssa-threadupdate.h + tree-ssa-threadupdate.h inchash.h # generate the 'build fragment' b-header-vars s-header-vars: Makefile diff --git a/main/gcc/ada/ChangeLog b/main/gcc/ada/ChangeLog index 613d2db5528..70db1c1f456 100644 --- a/main/gcc/ada/ChangeLog +++ b/main/gcc/ada/ChangeLog @@ -1,3 +1,4985 @@ +2014-08-04 Claire Dross + + * exp_util.adb (Get_First_Parent_With_Ext_Axioms_For_Entity): + For an instance, look at the scope before the generic parent. + +2014-08-04 Yannick Moy + + * lib-writ.ads: Update comments. + * sem_disp.ads, sem_disp.adb (Inherited_Subprograms): Add + parameters to filter inherited subprograms. + +2014-08-04 Robert Dewar + + * gnat_rm.texi: Add section on use of address clause for memory + mapped I/O. + +2014-08-04 Ed Schonberg + + * sem_ch3.adb (Analyze_Subtype_Declaration): A subtype, in + particular the subtype created for a generic actual, inherits + invariant information from the base type. + +2014-08-04 Robert Dewar + + * aspects.ads, aspects.adb: Add entries for aspect Obsolescent. + * gnat_rm.texi: Add documentation for aspect Obsolescent. + * sem_ch13.adb (Analyze_Aspect_Specifications): Implement aspect + Obsolescent. + (Check_Aspect_At_Freeze_Point): Add dummy entry for pragma Obsolescent. + * s-osprim-mingw.adb: Minor reformatting. + * sem_res.adb (Is_Atomic_Ref_With_Address): New function + (Resolve_Indexed_Component): Rework warnings for non-atomic access + (Resolve_Selected_Component): Add warnings for non-atomic access. + +2014-08-04 Doug Rupp + + * g-calend.adb (timeval_to_duration, duration_to_timeval): Change sec + formal to long_long. + * g-calend.ads (timeval): Bump up size to accomodate sec type. + * s-taprop-linux.adb (timeval_to_duration): Change sec formal to + long_long + * s-osprim-posix.adb (timeval): Bump up size to accomodate + new sec type. + (timeval_to_duration): Change sec formal to Long_Long_Integer + * s-osinte-darwin.adb (timeval): Bump up + size to accomodate new sec type. + (timeval_to_duration): Change sec formal to long_long + * s-osinte-android.adb: Likewise. + * cal.c (__gnat_timeal_to_duration, __gnat_duration_to_timeval): Change + sec formal from long to long long. + +2014-08-04 Robert Dewar + + * sem_res.adb (Resolve_Qualified_Expression): Make sure + Do_Range_Check flag gets set. + +2014-08-04 Robert Dewar + + * einfo.ads, einfo.adb (Is_Standard_String_Type): New function. + * exp_ch3.adb (Build_Array_Init_Proc): Use + Is_Standard_String_Type. + (Expand_Freeze_Array_Type): ditto. + (Get_Simple_Init_Val): ditto. + (Needs_Simple_Initialization): ditto. + * sem_eval.adb (Eval_String_Literal): Use Is_Standard_String_Type. + * sem_warn.adb (Is_Suspicious_Type): Use Is_Standard_String_Type. + +2014-08-04 Pascal Obry + + * adaint.c (__gnat_try_lock): Use _tcscpy and _tcscat instead of + _stprintf which insert garbage into the wfull_path buffer. + +2014-08-04 Arnaud Charlet + + * cal.c: Remove old VMS/nucleus code. Remove obsolete vxworks + code. + * fe.h: Minor reformatting. + +2014-08-04 Rainer Orth + + * cstreams.c: (_LARGEFILE_SOURCE): Guard definition. + +2014-08-04 Robert Dewar + + * par-ch13.adb (Get_Aspect_Specifications): Improve error + recovery, fixing a -gnatQ bomb. + +2014-08-04 Yannick Moy + + * sem_ch3.adb (Analyze_Object_Declaration): In GNATprove mode, + do not generate two Itypes with the same name for an array + definition. + * sinfo.ads: Expand doc on GNATprove mode. + +2014-08-04 Hristian Kirtchev + + * exp_ch3.adb (Expand_Freeze_Record_Type): Set the finalization + master and storage pool attributes on the root type of an + anonymous access type. + * exp_ch4.adb (Expand_N_Allocator): Set the finalization master + and storage pool attributes on the root type of an anonymous + access type. + +2014-08-04 Arnaud Charlet + + * exp_ch3.adb: Minor reformatting. + * tb-alvms.c, tb-alvxw.c, tb-ivms.c: Removed. + * tracebak.c: Remove use of above files. + * gcc-interface/Makefile.in: Update dependencies. + +2014-08-04 Pierre-Marie Derodat + + * gcc-interface/utils.c (gnat_set_type_context): Also set the + context for parallel types' TYPE_STUB_DECL. Do not change + anything if the context is already set for them. + (gnat_pushdecl): Update the comment for calls to + gnat_set_type_context to mention parallel types. + (add_parallel_type): When adding a context-less parallel type to + a type that has a context, propagate the context from the latter + type to the former. + (process_deferred_decl_context): Call gnat_set_type_context + rather than manually setting the type context. + (build_unc_object_type): Call gnat_set_type_context on the + template type. + +2014-08-04 Ed Schonberg + + * exp_ch5.adb (Expand_N_Case_Statement): If a choice is a + subtype indication and the case statement has only two choices, + replace subtype indication with its range, because the resulting + membership test cannot have a subtype indication as an operand. + +2014-08-04 Arnaud Charlet + + * exp_ch3.adb: Update comments, minor reformatting. + +2014-08-04 Hristian Kirtchev + + * sem_ch3.adb (Analyze_Declarations): Explain why the bodies of + the default initial condition procedures are build here. + * sem_util.adb (Build_Default_Init_Cond_Procedure): Wrap the + analyzed argument of pragma Default_Initial_Condition in some + dummy code as GNATprove mode disables assertions, but still + needs to see the argument. + +2014-08-04 Robert Dewar + + * exp_ch6.adb, sem_util.adb: Minor reformatting. + +2014-08-04 Olivier Hainque + + * a-comutr.ads: Set Root_Node_Type'Alignment to + Standard'Maximum_Alignment, so that it is at least as large as + the max default for Tree_Node_Type'Alignment. + +2014-08-04 Hristian Kirtchev + + * exp_ch3.adb (Freeze_Type): Remove the generation and inheritance + of the default initial condition procedure [body]. + * sem_ch3.adb (Analyze_Declarations): Create the bodies of + all default initial condition procedures at the end of private + declaration analysis. + * sem_util.adb (Build_Default_Init_Cond_Procedure_Bodies): New + routine. + (Build_Default_Init_Cond_Procedure_Body): Merged in the + processing of routine Build_Default_Init_Cond_Procedure_Bodies. + * sem_util.ads (Build_Default_Init_Cond_Procedure_Bodies): + New routine. + (Build_Default_Init_Cond_Procedure_Body): Removed. + +2014-08-04 Ed Schonberg + + * sem_elab.adb (Check_Elab_Call): Do not check a call to a + postcondtion. + * exp_ch6.adb (Expand_Call): Clarify handling of inserted + postcondition call. + +2014-08-04 Hristian Kirtchev + + * sem_prag.adb (Analyze_Pragma): Ensure that an + internally generated spec for a stand alone body is recognized + as a proper context for pragma SPARK_Mode. + +2014-08-04 Robert Dewar + + * erroutc.adb (Delete_Msg): Do not decrement Warnings_Treated_As_Errors. + +2014-08-04 Arnaud Charlet + + * adabkend.adb (Scan_Back_End_Switches): Ignore extra -o + when -gnatO has already been specified, for compatibility + with gcc driver. + (Scan_Compiler_Args): Do not call Set_Output_Object_File_Name in + codepeer mode. + * g-expect.ads: Fix typo. + +2014-08-04 Thomas Quinot + + * exp_ch4.adb (Insert_Dereference_Action): the actual Size + must account for the bounds template if the designated type is + an unconstrained array. + +2014-08-04 Hristian Kirtchev + + * a-cfhama.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb Add + SPARK_Mode in the body. + * sem_ch7.adb (Analyze_Package_Body_Helper): Restore the original + way to verify the consistency of SPARK_Mode between a spec and + a body. + * sem_ch12.adb (Analyze_Package_Instantiation): Remove the call + to Set_Ignore_Pragma_SPARK_Mode. Set flag Ignore_Pragma_SPARK_Mode + manually. + (Analyze_Subprogram_Instantiation): Remove the call to + Set_Ignore_Pragma_SPARK_Mode. Set flag Ignore_Pragma_SPARK_Mode + manually. + * sem_prag.adb (Analyze_Pragma): Remove local variable + Inst_Id. SPARK_Mode can no longer be applied to a package or + subprogram instantiation. + * sem_util.adb, sem_util.ads (Set_Ignore_Pragma_SPARK_Mode): + Removed. + +2014-08-04 Robert Dewar + + * sem_prag.adb, osint.adb, osint.ads: Minor reformatting. + +2014-08-04 Yannick Moy + + * sem_ch3.adb (Derive_Type_Declaration, + Process_Discriminants): Remove SPARK-specific legality checks. + +2014-08-04 Thomas Quinot + + * g-sechas.ads, g-sechas.adb (HMAC_Initial_Context): New subprogram. + * gnat_rm.texi (GNAT.MD5/SHA1/SHA224/SHA256/SHA512): Document support + for HMAC. + +2014-08-04 Hristian Kirtchev + + * sem_ch7.adb (Analyze_Package_Body_Helper): When verifying the + compatibility of SPARK_Mode between a spec and a body, use the + SPARK_Mode of the public part. + * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Use + the already available routine to exchange the aspects between + the template and its copy. Analyze the aspects of copy to + ensure that the corresponding pragmas perform their semantic + effects. The partial analysis of aspects is no longer needed. + (Analyze_Package_Instantiation): Save and restore the SPARK_Mode + of the context. + (Analyze_Subprogram_Instantiation): Save and restore the SPARK_Mode of + the context. + * sem_prag.adb (Analyze_Pragma): Do not bypass a subprogram + instantiation which does not come from source. + +2014-08-04 Hristian Kirtchev + + * a-cfhama.ads, a-cfhase.ads, a-cforma.ads, a-cforse.ads Add + SPARK_Mode pragmas to the public and private part of the unit. + * sem_ch3.adb (Derive_Type_Declaration): Ensure that a derived + type cannot have discriminants if the parent type already has + discriminants. + (Process_Discriminants): Ensure that the type of a discriminant is + discrete. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): The check on + SPARK_Mode compatibility between a spec and a body can now be + safely performed while processing a generic. + * sem_ch7.adb (Analyze_Package_Body_Helper): The check on + SPARK_Mode compatibility between a spec and a body can now be + safely performed while processing a generic. + * sem_prag.adb (Analyze_Pragma): Pragma SPARK_Mode can now be + safely analyzed when processing a generic. + +2014-08-04 Nicolas Roche + + * g-dirope.adb: Minor reformating. + +2014-08-04 Robert Dewar + + * sem_ch6.adb: Minor reformatting. + +2014-08-04 Ed Schonberg + + * sem_prag.adb (Analyze_Pragma, case Assert and related pragmas): + Before normalizing these pragmas into a pragma Check, preanalyze + the optional Message argument, (which is subsequently copied) + so that it has the proper semantic information for ASIS use. + * sem_case.adb: Initialize flag earlier. + * osint.adb, osint.ads (Find_File): Add parameter Full_Name, used when + the full source path of a configuration file is requested. + (Read_Source_File): Use Full_Name parameter.. + +2014-08-04 Hristian Kirtchev + + * opt.ads Alphabetize various global flags. New flag + Ignore_Pragma_SPARK_Mode along with a comment on usage. + * sem_ch6.adb (Analyze_Generic_Subprogram_Body): + Pragma SPARK_Mode is now allowed in generic units. + (Analyze_Subprogram_Body_Helper): Do not verify the compatibility + between the SPARK_Mode of a spec and that of a body when inside + a generic. + * sem_ch7.adb (Analyze_Package_Body_Helper): Do not verify the + compatibility between the SPARK_Mode of a spec and that of a + body when inside a generic. + * sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): + Pragma SPARK_Mode is now allowed in generic units. + (Analyze_Package_Instantiation): Save and restore the value of + flag Ignore_ Pragma_SPARK_Mode in a stack-like fasion. Set + the governing SPARK_Mode before analyzing the instance. + (Analyze_Subprogram_Instantiation): Save and restore the value + of flag Ignore_ Pragma_SPARK_Mode in a stack-like fasion. Set + the governing SPARK_Mode before analyzing the instance. + * sem_ch13.adb (Analyze_Aspect_Specifications): Emulate the + placement of a source pragma when inserting the generated pragma + for aspect SPARK_Mode. + * sem_prag.adb (Analyze_Pragma): Reimplement the handling of + pragma SPARK_Mode to allow for generics and their respective + instantiations. + * sem_util.ads, sem_util.adb (Check_SPARK_Mode_In_Generic): Removed. + (Set_Ignore_Pragma_SPARK_Mode): New routine. + +2014-08-04 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Deal with + renaming discriminants in tagged types first. + * gcc-interface/trans.c (gnat_to_gnu) : Test + the underlying type of the prefix. + (Pragma_to_gnu, case Pragma_Warning): Ignore Reason => "..." + (process_freeze_entity): Reset the nodes of + all the view of a type, if any. + +2014-08-04 Doug Rupp + Olivier Hainque + + * gcc-interface/Makefile.in (x86 VxWorks): Add filter-out for vxworks7 + and remove incorrect EH_MECHANISM macros. + Add sigtramp.h to EXTRA_LIBGNAT_SRCS when we add sigtramp-vxworks.o to + EXTRA_LIBGNAT_OBJS. + +2014-08-04 Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference): Make sure prefix + of constructed 'Valid attribute in -gnatVa mode does not appear + to come from source. + * sem_attr.adb (Analyze_Access_Attribute): Don't set + Never_Set_In_Source for non-source reference. + * sem_util.adb: Minor reformatting. + * sem_warn.adb (Check_References): Don't check Address_Taken, + not necessary, see comment. + +2014-08-04 Robert Dewar + + * sem_util.adb, sem_case.adb: Minor reformatting. + +2014-08-04 Ed Schonberg + + * exp_ch9.adb (Extract_Entry): If the synchronized object is a + limited view, replace with non-limited view, which is available + at the point of an entry call. + +2014-08-04 Ed Schonberg + + * exp_ch6.adb (Expand_Call): If the call is to a function in + a run-time unit that is marked Inline_Always, we must suppress + debugging information on it, so that the code that is eventually + inlined will not affect debugging of the user program. + +2014-08-04 Robert Dewar + + * inline.adb, einfo.ads, s-tassta.adb, s-tarest.adb: Minor comment + fixes. + +2014-08-04 Ed Schonberg + + * sem_prag.adb (Process_Import_Or_Interface): Handle properly + an aspect Import that specifies a False value. + +2014-08-04 Robert Dewar + + * gnat_rm.texi: Add section on aspect Invariant'Class. + +2014-08-04 Ed Schonberg + + * sem_case.adb (Check_Choice_Set): New flag Predicate_Error, + for better control of cascaded error messages when some choice + in a case statement over a predicated type violates the given + static predicate. + +2014-08-04 Hristian Kirtchev + + * sem_ch3.adb (Build_Derived_Type): Modify the + inheritance of the rep chain to ensure that a non-tagged type's + items are not clobbered during the inheritance. + +2014-08-04 Robert Dewar + + * sem_ch3.adb, einfo.ads: Minor reformatting. + +2014-08-04 Yannick Moy + + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Fix + detection of subprograms that cannot be inlined in GNATprove mode. + +2014-08-04 Ed Schonberg + + * einfo.adb: Add guard to Returns_Limited_View. + +2014-08-04 Jose Ruiz + + * s-tassta.adb, s-tarest.adb (Task_Wrapper): Force maximum alignment of + the secondary stack to respect the alignments of the returned objects. + +2014-08-04 Ed Schonberg + + * einfo.ads, einfo.adb (Returns_Limited_View): New flag defined + on function entities whose return type is a limited view. + * freeze.adb (Freeze_Entity): Use Returns_Limited_View to determine + where to place the freeze node for a function that returns the + limited view of a type, when the function is called and frozen + in a different unit. + +2014-08-04 Eric Botcazou + + * sem_ch3.adb (Build_Derived_Private_Type): Minor code + refactoring. + +2014-08-04 Robert Dewar + + * gnat_ugn.texi: Clarify documentation on assertions. + +2014-08-04 Ed Schonberg + + * sem_aggr.adb (Resolve_Record_Aggregate, Get_Value): Warn + if a component association has a box initialization when the + component type has no default initialization, either through an + initial value, an aspect, or an implicit initialization procedure. + +2014-08-04 Ed Schonberg + + * freeze.adb: Code clean up. + +2014-08-04 Thomas Quinot + + * sem_ch5.adb: Minor reformatting. + +2014-08-04 Ed Schonberg + + * freeze.adb (Late_Freeze_Subprogram): 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. + +2014-08-04 Robert Dewar + + * exp_ch5.adb, sem_ch5.adb, einfo.ads: Minor reformatting. + +2014-08-04 Arnaud Charlet + + * sem_ch4.adb (Operator_Check): Refine previous change. + +2014-08-04 Arnaud Charlet + + * sem_scil.ads: Improve comments. + * sem_ch4.adb (Analyze_Equality_Op): Add support for + Allow_Integer_Address (equality between Address and Integer). + +2014-08-04 Yannick Moy + + * a-cfhama.adb, a-cforse.adb: Minor fixes to avoid using prefix + notation on untagged objects. + * sem.ads: Update comment. + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Do + not inline subprograms declared in the visible part of a package. + +2014-08-04 Ed Schonberg + + * exp_ch5.adb: minor reformatting. + * einfo.ads, einfo.adb (Is_Processed_Transient): Applies to loop + parameters. + +2014-08-04 Thomas Quinot + + * s-fatgen.adb: Minor reformatting. + +2014-08-04 Arnaud Charlet + + * exp_util.adb (Is_Possibly_Unaligned_Object): Always return + False on .NET. + +2014-08-04 Ed Schonberg + + * sem_ch5.adb (Analyze_Loop_Statement): Set properly the kind of + the loop parameter for element iterators over containers and + arrays, so that improper uses of it are detected in the loop + body when expansion is disabled. + * exp_ch5.adb (Expand_Iterator_Loop): The entity kind of the + generated cursor is that of the analyzed loop parameter. + +2014-08-04 Hristian Kirtchev + + * exp_ch3.adb (Build_CPP_Init_Procedure): Remove + Flag_Decl. Do not analyze the declaration of the flag as it is + not part of the tree yet, instead add it to the freeze actions + of the C++ type. + +2014-08-04 Robert Dewar + + * checks.adb (Apply_Scalar_Range_Check): Make sure we handle + case of OUT and IN OUT parameter correctly (where Source_Typ is + set), we were missing one case where a check must be applied. + +2014-08-04 Hristian Kirtchev + + * sem_ch8.adb (Build_Class_Wide_Wrapper): Update the comment on + the generated code. Instead of hiding the renaming and using the + wrapper as the proper association, have the subprogram renaming + alias the wrapper. + (Build_Spec): The entity of the wrapper is + now derived from the entity of the related primitive. + +2014-08-04 Emmanuel Briot + + * s-regpat.adb: s-regpat.adb (Parse): fix incorrect link when + using non-capturing groups. + +2014-08-04 Ed Schonberg + + * inline.adb (Build_Body_To_Inline): Remove Unmodified and + related pragmas before copying the original body, to prevent + spurious errors when the pragmas apply to formals that will not + appear in the inlined body. + +2014-08-04 Robert Dewar + + * exp_prag.adb, sem_ch7.adb, einfo.adb, sem_prag.adb, sem_util.adb, + exp_ch3.adb: Minor reformatting. + +2014-08-04 Robert Dewar + + * prj-strt.adb, prj-strt.ads, sem_attr.adb: Minor reformatting. + +2014-08-04 Hristian Kirtchev + + * aspects.adb Add an entry in table Canonical_Aspect for + Default_Initial_Condition. + * aspects.ads Add an entry in tables Aspect_Id, Aspect_Argument, + Aspect_Names and Aspect_Delay for Default_Initial_Condition. + * einfo.adb Flag3 is now Has_Default_Init_Cond. Flag132 + is now Is_Default_Init_Cond_ Procedure. Flag133 is now + Has_Inherited_Default_Init_Cond. + (Default_Init_Cond_Procedure): New routine. + (Has_Default_Init_Cond): New routine. + (Has_Inherited_Default_Init_Cond): New routine. + (Is_Default_Init_Cond_Procedure): New routine. + (Set_Default_Init_Cond_Procedure): New routine. + (Set_Has_Default_Init_Cond): New routine. + (Set_Has_Inherited_Default_Init_Cond): New routine. + (Set_Is_Default_Init_Cond_Procedure): New routine. + (Write_Entity_Flags): Output all the new flags. + * einfo.ads New attributes Default_Init_Cond_Procedure, + Has_Inherited_Default_Init_Cond and Is_Default_Init_Cond_Procedure + along with usage in nodes. + (Default_Init_Cond_Procedure): New routine. + (Has_Default_Init_Cond): New routine and pragma Inline. + (Has_Inherited_Default_Init_Cond): New routine and + pragma Inline. + (Is_Default_Init_Cond_Procedure): New routine and + pragma Inline. + (Set_Default_Init_Cond_Procedure): New routine. + (Set_Has_Default_Init_Cond): New routine and pragma Inline. + (Set_Has_Inherited_Default_Init_Cond): New routine and pragma Inline. + (Set_Is_Default_Init_Cond_Procedure): New routine and pragma Inline. + * exp_ch3.adb (Expand_N_Object_Declaration): New constant + Next_N. Generate a call to the default initial condition procedure + if the object's type is subject to the pragma. (Freeze_Type): + Generate the body of the default initial condition procedure or + inherit the spec from a parent type. + * exp_ch7.adb Add with and use clause for Exp_Prag. + (Expand_Pragma_Initial_Condition): Removed. + * exp_prag.ads, exp_prag.adb (Expand_Pragma_Initial_Condition): New + routine. + * par-prag.adb (Prag): Pragma Default_Initial_Condition does + not need special treatment by the parser. + * sem_ch3.adb (Build_Derived_Record_Type): Propagate the + attributes related to pragma Default_Initial_Condition to the + derived type. + (Process_Full_View): Propagate the attributes + related to pragma Default_Initial_Condition to the full view. + * sem_ch7.adb (Analyze_Package_Specification): Build the + declaration of the default initial condition procedure for all + types that qualify or inherit the one from the parent type. + * sem_ch13.adb (Analyze_Aspect_Specifications): + Add processing for aspect Default_Initial_Condition. + (Check_Aspect_At_Freeze_Point): Aspect + Default_Initial_Condition does not require delayed analysis. + (Replace_Type_References_Generic): Moved to spec. + * sem_ch13.ads (Replace_Type_References_Generic): Moved from body. + * sem_prag.adb Add an entry in table Sif_Glags for + Default_Initial_Condition. + (Analyze_Pragma): Pragma + Default_Initial_Condition is now part of assertion + policy. Add processing for pragma Default_Initial_Condition. + (Is_Valid_Assertion_Kind): Pragma Default_Initial_Condition is + now recognized as a proper assertion policy. + * sem_util.ads, sem_util.adb (Build_Default_Init_Cond_Call): New + routine. + (Build_Default_Init_Cond_Procedure_Body): New routine. + (Build_Default_Init_Cond_Procedure_Declaration): New routine. + (Inherit_Default_Init_Cond_Procedure): New routine. + * snames.ads-tmpl Add new predefined name and pragma id for + Default_Initial_Condition. + +2014-08-04 Vincent Celier + + * prj-dect.adb (Parse_Case_Construction): It is no longer + an error if the variable for a case construction is not + typed, only if the variable value is not a single string. Call + Parse_Choice_List and End_Case_Construction with the new parameter + to indicate that the variable is typed. + * prj-strt.adb (End_Case_Construction): Only check the labels + if the variable is typed. If the variable is not typed, + issue a warning when there is no "when others" allternative. + (Parse_Choice_List): Manage the labels only if the variable + is typed. + * prj-strt.ads (End_Case_Construction): New Boolean parameter + String_Type. + (Parse_Choice_List): Ditto. + +2014-08-04 Ed Schonberg + + * sem_ch5.adb: Additional fix to Check_Predicate_Use. + +2014-08-04 Vincent Celier + + * projects.texi: Update documentation of case constructions with + variables that are not typed. + +2014-08-04 Ed Schonberg + + * sem_ch8.adb (Build_Class_Wide_Wrapper): If the operator carries + an Eliminated pragma, indicate that the wrapper is also to be + eliminated, to prevent spurious errors when using gnatelim on + programs that include box-initialization of equality operators + (consequence of AI05-071).. + +2014-08-04 Robert Dewar + + * checks.adb (Activate_Overflow_Check): Handle floating-point + case correctly. + * checks.ads (Activate_Overflow_Check): Clarify handling of + floating-point cases. + * exp_util.adb (Check_Float_Op_Overflow): Reset Do_Overflow_Check + flag if we generate an explicit overflow check (for + Check_Float_Overflow mode). + +2014-08-04 Robert Dewar + + * prj-proc.adb, prj-part.adb, prj-strt.adb, prj.adb, prj.ads, + prj-attr.adb, prj-attr.ads: Minor reformatting. + +2014-08-04 Yannick Moy + + * expander.adb (Expand): Always perform special + expansion in GNATprove mode, even when doing pre-analysis. + +2014-08-04 Thomas Quinot + + * repinfo.adb (List_Scalar_Storage_Order): List bit order if + not default. Also list bit order if SSO is specified. Do not + assume that bit order is always equal to scalar storage order. + +2014-08-04 Thomas Quinot + + * freeze.adb (Set_SSO_From_Default): Do not set scalar storage + order to reverse SSO for a type that has an explicit native + Bit_Order. + +2014-08-04 Doug Rupp + + * cal.c: Macro check for VxWorks7. + * init.c (getpid): Likewise. + * mkdir.c (__gnat_mkdir): Likewise. + * sysdep.c (__gnat_is_file_not_found_error): Likewise. + +2014-08-04 Gary Dismukes + + * exp_ch3.adb (Expand_N_Object_Declaration): Inhibit generation + of an invariant check in the case where No_Initialization is set, + since the object is uninitialized. + +2014-08-04 Thomas Quinot + + * snames.ads-tmpl (Default_Scalar_Storage_Order): Now an attribute + name, in addition to a pragma name. + * snames.adb-tmpl (Get_Pragma_Id, Is_Configuration_Pragma_Name, + Is_Pragma_Name): Adjust accordingly. + * sem_attr.ads, sem_attr.adb, exp_attr.adb + (Attribute_Default_Scalar_Storage_Order): Add handling of new + attribute. + * gnat_rm.texi: Document the above. + +2014-08-04 Arnaud Charlet + + * exp_util.adb (Check_Float_Op_Overflow): No-op in codepeer + mode for now, to revert to previous behavior. + * checks.adb: Revert previous change, no longer needed. + +2014-08-04 Robert Dewar + + * gnat1drv.adb (Adjust_Global_Switches): Don't set + Check_Float_Overflow if Machine_Oveflows_On_Target is True. + * sem_prag.adb (Analyze_Pragma, case Check_Float_Overflow): Don't + set Check_Float_Overflow if Machine_Oveflows_On_Target is True. + * switch-c.adb (Scan_Front_End_Switches): Don't set + Check_Float_Overflow if Machine_Oveflows_On_Target is True. + +2014-08-04 Vincent Celier + + * prj-attr.adb: Add new default indications for + attributes Object_Dir, Exec_Dir, Source_Dirs and Target. + (Attribute_Default_Of): New function (Initialize): Set the + default for those attributes that have one specified. + * prj-attr.ads (Attribute_Data): New component Default. + * prj-proc.adb (Expression): Take into account the new defaults + for attributes Object_Dir, Exec_Dir and Source_Dirs. + * prj-strt.adb (Attribute_Reference): Set the default for + the attribute. + * prj-tree.ads, prj-tree.adb (Default_Of): New function. + (Set_Default_Of): New procedure. + * prj.adb (The_Dot_String): New global Name_Id variable, + initialized in procedure Initialize. + (Dot_String): New function + (Initialize): Initialize The_Dot_String. + (Reset): Create the string list Shared.Dot_String_List. + * prj.ads (Attribute_Default_Value): New enumeration type. + (Project_Qualifier): Change enumeration value Dry to Abstract_Project. + (Dot_String): New function. + (Shared_Project_Tree_Data): New string list component Dot_String_List. + * projects.texi: Document new defaults for attribute Object_Dir, + Exec_Dir and Source_Dirs. + +2014-08-04 Robert Dewar + + * sem_ch12.adb: Minor reformatting. + +2014-08-04 Arnaud Charlet + + * exp_util.adb, checks.adb (Check_Float_Op_Overflow): Add special + expansion in CodePeer_Mode. + (Selected_Range_Checks): Add handling of overflow checks in + CodePeer_Mode. + +2014-08-04 Robert Dewar + + * exp_attr.adb (Expand_N_Attribute_Reference, case Pred): + Remove special test for Float'First, no longer required. + (Expand_N_Attribute_Reference, case Succ): Remove special test + for Float'First, no longer required. + * s-fatgen.adb (Pred): return infinity unchanged. + (Succ): ditto. + +2014-08-04 Claire Dross + + * sem_ch12.adb (Analyze_Associations): Defaults should only be + used if there is no explicit match. + * exp_util.adb (Get_First_Parent_With_Ext_Axioms_For_Entity): + Also check for pragma external_axiomatization on generic units. + +2014-08-04 Robert Dewar + + * checks.adb (Activate_Overflow_Check): Remove + Check_Float_Overflow processing. + (Apply_Scalar_Range_Check): Ditto. + (Generate_Range_Check): Ditto. + * exp_ch4.adb (Expand_N_Op_Add): Add call to + Check_Float_Op_Overflow. + (Expand_N_Op_Divide): ditto. + (Expand_N_Op_Multiply): ditto. + (Expand_N_Op_Subtract): ditto. + * exp_util.ads, exp_util.adb (Check_Float_Op_Overflow): New procedure. + * sem_attr.adb (Analyze_Attribute, case Pred): Make sure + Do_Range_Check is set for floating-point case in -gnatc or + GNATprove mode. + (Analyze_Attribute, case Succ): Make sure + Do_Range_Check is set for floating-point case in -gnatc or + GNATprove mode. + * sem_res.adb (Resolve_Type_Conversion): Make sure Do_Range_Check + flag is set for real to integer conversion in GNATprove or + -gnatc mode. + +2014-08-04 Gary Dismukes + + * sem_ch13.adb (Analyze_Aspect_Specifications): Resolve + the expression of an Import or Export aspect as type Boolean + and require it to be static. Add ??? comment. Also, set the + Is_Exported flag when appropriate. + +2014-08-04 Robert Dewar + + * exp_ch4.adb: Minor reformatting. + * exp_attr.adb: Minor reformatting. + +2014-08-04 Thomas Quinot + + * s-fatgen.ads, s-fatgen.adb (S, P): New visible type declarations + (Unaligned_Valid): Remove now unused subprogram. + * exp_attr.adb (Expand_N_Attribute_Reference, case + Attribute_Valid): If the prefix is in reverse SSO or potentially + unaligned, copy it using a byte copy operation to a temporary + variable. + * einfo.adb: Minor comment fix. + +2014-08-04 Hristian Kirtchev + + * freeze.adb (Freeze_Entity): Do not freeze formal subprograms. + +2014-08-04 Robert Dewar + + * s-imgrea.adb (Image_Floating_Point): Don't add space before +Inf. + * s-fatgen.adb (Pred): Handle Float'First. + (Succ): Handle Float'Last. + +2014-08-04 Ed Schonberg + + * sem_util.adb (Is_Potentially_Unevaluated): If the original + node of a parent node in the tree is a short-circuit operation, + the node is potentially unevaluated. + +2014-08-04 Robert Dewar + + * sem_res.adb (Resolve_Type_Conversion): Set Do_Range_Check on + conversion from a real type to an integer type. + +2014-08-04 Yannick Moy + + * sem_aggr.adb, sem_ch3.adb, sem_ch5.adb, sem_ch7.adb, sem_ch9.adb, + sem_ch12.adb, sem_util.adb, sem_util.ads, sem_res.adb, sem_attr.adb, + exp_ch6.adb, sem_ch4.adb, restrict.adb, restrict.ads, sem_ch6.adb, + sem_ch8.adb, sem_ch11.adb: Update some subprogram names to refer to + SPARK_05 instead of SPARK. + +2014-08-04 Robert Dewar + + * sem.ads: Minor reformatting. + * sem_ch13.adb (Analyze_Aspect_External_Or_Link_Name): Minor + reformatting. + (Analyze_Aspect_Specifications, case Convention): Put External_Name + before Link_Name when constructing pragma. + +2014-08-04 Yannick Moy + + * sem.adb, sem.ads (In_Default_Expr): Global flag that is set + to True during analysis of a default component expression. + (Semantics): Save and restore In_Default_Expr around analysis. + * sem_ch3.adb, sem_ch3.ads (Analyze_Component_Declaration): + Call new wrapper Preanalyze_Default_Expression. + (Preanalyze_Default_Expression): New wrapper on + Preanalyze_Spec_Expression which sets and restores In_Default_Expr. + * sem_res.adb (Resolve_Call): Mark calls inside default + expressions as not inlined in GNATprove mode. + +2014-08-04 Robert Dewar + + * exp_ch4.adb: Minor reformatting. + +2014-08-04 Olivier Hainque + + * link.c: remove const on __gnat_objlist_file_supported for AIX + +2014-08-04 Robert Dewar + + * sem_util.ads: Minor addition of comment. + +2014-08-04 Vincent Celier + + * prj-dect.adb (Check_Package_Allowed): Allow package IDE in + all projects, including aggregate and aggregate library projects. + +2014-08-04 Yannick Moy + + * back_end.adb (Call_Back_End): Do not call gigi in GNATprove mode. + +2014-08-04 Robert Dewar + + * sem_eval.adb (Test_In_Range): Always in range for + Is_Known_Valid target type, where input type has smaller or + equal size and does not have biased rep. + +2014-08-04 Ed Schonberg + + * sem_attr.adb (Eval_Attribute): Constrained is not treated as + a static attribute, and the Static flag must not be set on it + during resolution. It may be constant-folded during expansion, + but if expansion is disabled it is not a static expression. + +2014-08-04 Hristian Kirtchev + + * sem_ch8.adb (Build_Class_Wide_Wrapper): Mark the primitive as + referenced once resolution has taken place. + +2014-08-04 Gary Dismukes + + * exp_ch4.adb (Expand_N_Type_Conversion): Don't + compare access levels in the case where the target type is the + anonymous type of an access discriminant, since the level of + such types is defined based on context. Add comment. + +2014-08-04 Hristian Kirtchev + + * sem_ch8.adb (Build_Class_Wide_Wrapper): Handle various special + cases related to equality. Remove the special processing + for dispatching abstract subprograms as it is not needed. + (Interpretation_Error): Add a specialized error message for + predefined operators. + (Is_Intrinsic_Equality): New routine. + (Is_Suitable_Candidate): New routine. + +2014-08-04 Gary Dismukes + + * checks.adb: Minor comment reformatting. + +2014-08-04 Ed Schonberg + + * restrict.adb (Check_Restriction): For checked max_parameter + restrictions reset Violated flag, so that subsequent violations + are properly detected. + +2014-08-04 Robert Dewar + + * sem_ch3.adb (Check_Initialization): Fix bad test of GNATprove + mode. + (Process_Discriminants): Fix bad test of GNATprove mode + +2014-08-04 Hristian Kirtchev + + * sem_ch12.adb (Instantiate_Formal_Subprogram): + Move variable to their own section. Propagate the source + location of a formal parameter to the corresponding formal of + the subprogram renaming declaration. Code reformatting. + +2014-08-04 Arnaud Charlet + + * g-trasym-vms-ia64.adb, g-trasym-vms-alpha.adb: Removed. + +2014-08-04 Ed Schonberg + + * exp_aggr.adb (Expand_Array_Aggregate): Do not attempt expansion + if error already detected. We may reach this point in spite of + previous errors when compiling with -gnatq, to force all possible + errors (this is the usual ACATS mode). + +2014-08-04 Gary Dismukes + + * checks.adb (Generate_Range_Check): For the case of converting + a base type with a larger range to a smaller target subtype, only + use unchecked conversions of bounds in the range check followed + by conversion in the case where both types are discrete. In other + cases, convert to the target base type and save in a temporary + followed by the range check. + (Convert_And_Check_Range): New procedure factoring code to save + conversion to a temporary followed by a range check (called two + places in Generate_Range_Check). + * exp_ch4.adb (Expand_N_Type_Conversion): Relax previous + check-in, to generate range checks for conversions between + any floating-point types rather than limiting it to matching + base types. + +2014-08-02 Trevor Saunders + + * gcc-interface/trans.c: Use hash_set instead of pointer_set. + +2014-08-01 Ed Schonberg + + * restrict.adb (Update_Restrictions): For restrictions with a + maximum parameter (e.g. number of protected entries in Ravenscar) + do not compute the maximum of the violation over several objects, + because the restriction is per-object. + (Check_Restriction): After possible message, reset the value + of of a checked max_parameter restriction to zero, to prevent + cascaded errors. + * sem_ch3.adb (Build_Derived_Private_Type): Use base of parent + (sub)type to determine whether derived type should be on the + list of private dependents of a type whose full view may become + visible subsequently. + +2014-08-01 Olivier Hainque + + * gcc-interface/Make-lang.in (ADA_TOOLS_FLAGS_TO_PASS, native): use + $(CXX) instead of ../../xg++ to feed CXX. + (CXX_LFLAGS): Remove. Now unused as the proper flags + are expected to be included in the CXX variable. + +2014-08-01 Pierre-Marie Derodat + + * gcc-interface/decl.c (elaborate_expression_1): Return the new + variable when debug info is needed and the expression is not + constant. Tag as external only new variables that are global. + (gnat_to_gnu_entity): Call it after the GNU declaration is saved. + * gcc-interface/trans.c (Attribute_to_gnu): Do not cache + attributes for IN array parameters when their actual subtype + needs debug info. + (Compilation_Unit_to_gnu): Call it to process all remaining nodes. + * gcc-interface/gigi.h (process_deferred_decl_context): New. + * gcc-interface/utils.c (gnat_write_global_declarations): Do not + emit debug info for ignored global declarations. + (struct deferred_decl_context_node, + add_deferred_decl_context, add_deferred_type_context, + compute_deferred_decl_context, defer_or_set_type_context, + deferred_decl_context_queue, get_debug_scope, + get_global_context, process_deferred_decl_context): New. + (gnat_pushdecl): Re-implement the DECL_CONTEXT and TYPE_CONTEXT + computation machinery to rely on the GNAT Scope attribute. + +2014-08-01 Eric Botcazou + + * gcc-interface/utils2.c (build_simple_component_ref): Add guard. + +2014-08-01 Robert Dewar + + * sem_ch8.adb, opt.ads Minor comment updates. + +2014-08-01 Hristian Kirtchev + + * exp_intr.adb (Expand_Unc_Deallocation): Request a renaming + from the side effects removal machinery. + * exp_util.adb (Duplicate_Subexpr): Add formal parameter + Renaming_Req. Update the nested call to Remove_Side_Effects. + (Duplicate_Subexpr_No_Checks): Add formal parameter + Renaming_Req. Update the nested call to Remove_Side_Effects. + (Duplicate_Subexpr_Move_Checks): Add formal parameter + Renaming_Req. Update the nested call to Remove_Side_Effects. + (Remove_Side_Effects): Add formal parameter Renaming_Req. Generate + an object renaming declaration when the caller requests it. + * exp_util.ads (Duplicate_Subexpr): Add formal + parameter Renaming_Req. Update comment on usage. + (Duplicate_Subexpr_No_Checks): Add formal parameter Renaming_Req. + (Duplicate_Subexpr_Move_Checks): Add formal parameter + Renaming_Req. + +2014-08-01 Bob Duff + + * gnat_ugn.texi: Minor updates. + +2014-08-01 Robert Dewar + + * atree.adb: Minor reformatting. + +2014-08-01 Ed Schonberg + + * exp_aggr.adb (Init_Hidden_Discriminants): If some ancestor is a + private extension, get stored constraint, if any, from full view. + +2014-08-01 Robert Dewar + + * opt.ads (No_Elab_Code_All_Pragma): New global variable. + * sem_ch10.adb (Check_No_Elab_Code_All): New procedure + (Analyze_Compilation_Unit): Call Check_No_Elab_Code_All + (Analyze_Subunit_Context): Call Check_No_Elab_Code_All. + * sem_prag.adb (Analyze_Pragma, case No_Elaboration_Code_All): + Remove code for checking with's, now in sem_ch10.adb, set + Opt.No_Elab_Code_All_Pragma. + +2014-08-01 Eric Botcazou + + * sem_ch3.adb (Copy_And_Build): Copy the declaration for + access types as well and adjust the subtype mark if there are + no constraints. + +2014-08-01 Robert Dewar + + * sem_eval.adb (Test_In_Range): Return Unknown if error posted. + +2014-08-01 Robert Dewar + + * sem_ch3.adb, einfo.ads, exp_ch4.adb: Code clean ups. + +2014-08-01 Eric Botcazou + + * einfo.ads (Has_Private_Ancestor): Remove obsolete usage. + * exp_ch4.adb (Expand_Composite_Equality): Add conversion + of the actuals in the case of untagged record types too. + * sem_ch3.adb (Build_Full_Derivation): New procedure to create the + full derivation of a derived private type, extracted from... + (Copy_And_Build): In the case of record types and most + enumeration types, copy the original declaration. Build the + full derivation according to the approach extracted from... + (Build_Derived_Private_Type): ...here. Call Build_Full_Derivation + to create the full derivation in all existing cases and also + create it in the no-discriminants/discriminants case instead of + deriving directly from the full view. + (Is_Visible_Component): Remove obsolete code. + * sem_aggr.adb (Resolve_Record_Aggregate): Likewise. + +2014-08-01 Arnaud Charlet + + * fe.h (GNAT_Mode): New. + * gcc-interface/decl.c (gnat_to_gnu_entity): Do not error out on + reverse SSO in GNAT mode. + +2014-08-01 Thomas Quinot + + * freeze.adb: Minor reformatting. + +2014-08-01 Thomas Quinot + + * exp_ch3.adb (Default_Initialize_Object): Do not generate + default initialization for an imported object. + +2014-08-01 Olivier Hainque + + * seh_init.c (__gnat_map_SEH): Cast argument of IsBadCodePtr + to the expected FARPROC type instead of void *. + * adaint.c (f2t): Expect __time64_t * as second argument, in line with + other datastructures. + (__gnat_file_time_name_attr): Adjust accordingly. + (__gnat_check_OWNER_ACL): Declare pSD as PSECURITY_DESCRIPTOR, + in line with uses. + (__gnat_check_OWNER_ACL): Declare AccessMode + parameter as ACCESS_MODE instead of DWORD, in line with callers + and uses. + (__gnat_set_executable): Add ATTRIBUTE_UNUSED on mode, + unused on win32. Correct cast of "args" on call to spawnvp. + (add_handle): Cast realloc calls into their destination types. + (win32_wait): Remove declaration and initialization of unused variable. + (__gnat_locate_exec_on_path): Cast alloca calls + into their destination types. + * initialize.c (append_arg, __gnat_initialize): Cast xmalloc calls into + their destination types. + +2014-08-01 Gary Dismukes + + * exp_ch4.adb (Expand_N_Type_Conversion): Expand + range checks for conversions between floating-point subtypes + when the target and source types are the same. + +2014-08-01 Robert Dewar + + * exp_aggr.adb: Minor reformatting. + +2014-08-01 Eric Botcazou + + * sem_ch13.adb (Check_Indexing_Functions): Initialize + Indexing_Found. + +2014-08-01 Arnaud Charlet + + * gnat1drv.adb (Gnat1drv): In gnatprove mode, we now write the + ALI file before we call the backend (so that gnat2why can append + to it). + +2014-08-01 Thomas Quinot + + * exp_pakd.adb (Expand_Bit_Packed_Element_Set, + Expand_Packed_Element_Reference): Pass additional Rev_SSO + parameter indicating whether the packed array type has reverse + scalar storage order to the s-pack* Set/Get routines. + * s-pack*.ad* (Get, Set, GetU, SetU): New formal Rev_SSO + indicating reverse scalar storage order. + +2014-08-01 Robert Dewar + + * sem_ch3.adb (Check_Initialization): Set Do_Range_Check + for initial component value in -gnatc or GNATprove mode. + (Process_Discriminants): Same fix for default discriminant values. + * sem_eval.adb (Test_In_Range): Improve accuracy of results by + checking subtypes. + +2014-08-01 Robert Dewar + + * sinfo.ads: Minor comment clarification. + +2014-08-01 Hristian Kirtchev + + * sem_ch13.adb (Analyze_Aspect_Specifications): Code + reformatting. Store the generated pragma Import in the related + subprogram as routine Wrap_Imported_Subprogram will need it later. + * sem_prag.adb (Is_Unconstrained_Or_Tagged_Item): An item of + a private type with discriminants is considered to fall in the + category of unconstrained or tagged items. + +2014-08-01 Arnaud charlet + + * s-os_lib.adb (Open_Append): New functions to open a file for + appending. This binds to the already existing (but not used) + __gnat_open_append. + * osint.ads, osint.adb (Open_File_To_Append_And_Check): New procedure + to open a file for appending. + * osint-c.ads, osint-c.adb (Open_Output_Library_Info): New procedure + to open the ALI file for appending. + +2014-08-01 Robert Dewar + + * sem_ch8.adb: Minor reformatting. + +2014-08-01 Yannick Moy + + * sem_ch13.adb (Insert_Pragma): Add special case for precondition + pragmas from aspects, which need to be inserted in proper order. + +2014-08-01 Ed Schonberg + + * exp_aggr.adb (Expand_Record_Aggregate, Init_Hidden_Discriminants): + Handle properly a type extension that constrains a discriminated + derived type that renames other discriminants of an ancestor. + +2014-08-01 Thomas Quinot + + * s-pack06.adb, s-pack10.adb, s-pack03.ads, s-pack12.adb, s-pack14.ads, + s-pack25.adb: Fix minor inconsistencies and typos. + +2014-08-01 Hristian Kirtchev + + * sem_ch8.adb (Analyze_Subprogram_Renaming): Alphabetize + globals and move certain variables to the "local + variable" section. Call Build_Class_Wide_Wrapper when + renaming a default actual subprogram with a class-wide actual. + (Build_Class_Wide_Wrapper): New routine. + (Check_Class_Wide_Actual): Removed. + (Find_Renamed_Entity): Code reformatting. + (Has_Class_Wide_Actual): Alphabetize. Change the + logic of the predicate as the renamed name may not necessarely + denote the correct subprogram. + +2014-08-01 Eric Botcazou + + * sem_ch7.adb: Fix minor oversight in condition. + +2014-08-01 Bob Duff + + * projects.texi: Minor documentation improvements. + +2014-08-01 Robert Dewar + + * aspects.ads, aspects.adb: Add aspect No_Elaboration_Code_All. + * gnat_rm.texi: Document No_Elaboration_Code_All pragma and aspect. + * lib-load.adb: Initialize No_Elab_Code_All field. + * lib-writ.adb: Initialize No_Elab_Code_All. + * lib.ads, lib.adb: New field No_Elab_Code_All. + * par-prag.adb: Add dummy entry for pragma No_Elaboration_Code_All. + * restrict.ads, restrict.adb: Restriction No_Elaboration_Code_All no + longer exists. + * sem_ch10.adb (Analyze_Context): Processing for + No_Elaboration_Code_All removed. + (Generate_Parent_References): Moved to Sem_Util. + * sem_prag.adb: Add processing for pragma No_Elaboration_Code_All. + * sem_util.ads, sem_util.adb (Get_Parent_Entity): Moved here from + Sem_Ch10. + * snames.ads-tmpl: Add entry for pragma No_Elaboration_Code_All. + * targparm.adb: Minor comment updates Add comments on ignoring + pragma No_Elaboration_Code_All. + +2014-08-01 Nicolas Roche + + * adaint.c (__gnat_set_close_on_exec): Ensure that + we can unset "close_on_exec" flag. + +2014-08-01 Ed Schonberg + + * exp_ch9.adb (Build_Wrapper_Spec, Replicate_Formals): When building + the parameter specs of the wrapper program for a primitive operation + of a synchronized type that implements an interface, copy the + null_exclusion indicator as well. + +2014-08-01 Robert Dewar + + * sem_eval.ads: Minor reformatting. + +2014-08-01 Eric Botcazou + + * exp_ch3.adb (Build_Initialization_Call): Call Underlying_Type + to go down the chain of private derivations. + * freeze.adb (Freeze_Entity): Fix typo in comment. + +2014-08-01 Ed Schonberg + + * sem_ch3.adb (Access_Type_Declaration): If designated type is + a limited view, create a master entity (as is already done for + class-wide types) in case the full view designates a type that + contains tasks. + * sem_ch8.adb (Find_Selected_Component): If prefix is a dereference + and the designated type is a limited view, use the non-limited + view if available. + +2014-08-01 Eric Botcazou + + * gcc-interface/ada-tree.h (DECL_BY_DESCRIPTOR_P): Delete. + (DECL_FUNCTION_STUB): Likewise. + (SET_DECL_FUNCTION_STUB): Likewise. + (DECL_PARM_ALT_TYPE): Likewise. + (SET_DECL_PARM_ALT_TYPE): Likewise. + (TYPE_VAX_FLOATING_POINT_P): Delete. + (TYPE_DIGITS_VALUE): Likewise. + (SET_TYPE_DIGITS_VALUE): Likewise. + * gcc-interface/gigi.h (standard_datatypes): Remove ADT_malloc32_decl. + (malloc32_decl): Delete. + (build_vms_descriptor): Likewise. + (build_vms_descriptor32): Likewise. + (fill_vms_descriptor): Likewise. + (convert_vms_descriptor): Likewise. + (TARGET_ABI_OPEN_VMS): Likewise. + (TARGET_MALLOC64): Likewise. + * gcc-interface/decl.c (add_parallel_type_for_packed_array): New. + (gnat_to_gnu_entity): Call it to add the original type as a parallel + type to the implementation type of a packed array type. + : Remove now obsolete kludge. + : Delete obsolete comment. + : Small tweak. + : Remove support for stub subprograms, as well as + for the descriptor passing mechanism. + (gnat_to_gnu_param): Likewise. + * gcc-interface/misc.c (gnat_init_gcc_fp): Remove special case. + (gnat_print_type): Adjust. + * gcc-interface/trans.c (gigi): Remove obsolete initializations. + (vms_builtin_establish_handler_decl): Delete. + (gnat_vms_condition_handler_decl): Likewise. + (establish_gnat_vms_condition_handler): Likewise. + (build_function_stub): Likewise. + (Subprogram_Body_to_gnu): Do not call above functions. + (Call_to_gnu): Remove support for the descriptor passing mechanism. + * gcc-interface/utils.c (make_descriptor_field): Delete. + (build_vms_descriptor32): Likewise. + (build_vms_descriptor): Likewise. + (fill_vms_descriptor): Likewise. + (convert_vms_descriptor64): Likewise. + (convert_vms_descriptor32): Likewise. + (convert_vms_descriptor): Likewise. + * gcc-interface/utils.c (unchecked_convert): Likewise. + * gcc-interface/utils2.c (maybe_wrap_malloc): Remove obsolete stuff. + +2014-08-01 Eric Botcazou + + * gcc-interface/trans.c (gigi): Use gnat_to_gnu_type for the exception + type and get_unpadded_type for the longest FP type. + (Attribute_to_gnu) : Compare the precision of the types. + (convert_with_check): Adjust formatting and remove FIXME. + +2014-08-01 Eric Botcazou + + * gcc-interface/decl.c (gnat_to_gnu_entity) : + Do not convert the RM bounds to the base type. + (E_Floating_Point_Subtype): Likewise. + (E_Array_Subtype): Convert the bounds to the base type. + * gcc-interface/trans.c (get_type_length): New function. + (Attribute_to_gnu) : Call it. + : Likewise. + (Loop_Statement_to_gnu): Convert the bounds to the base type. + (gnat_to_gnu) : Likewise. + * gcc-interface/utils.c (make_type_from_size): Do not convert the RM + bounds to the base type. + (create_range_type): Likewise. + (convert): Convert the bounds to the base type for biased types. + * gcc-interface/utils2.c (compare_arrays): Convert the bounds to the + base type. + +2014-08-01 Eric Botcazou + + * gcc-interface/trans.c (gnat_to_gnu) : Remove + incorrect implicit type derivation. + * gcc-interface/utils.c (max_size) : Convert the bounds + to the base type. + +2014-08-01 Hristian Kirtchev + + * sem_attr.adb (Analyze_Attribute): Preanalyze and resolve the + prefix of attribute Loop_Entry. + * sem_prag.adb (Analyze_Pragma): Verify the placement of pragma + Loop_Variant with respect to an enclosing loop (if any). + (Contains_Loop_Entry): Update the parameter profile and all + calls to this routine. + * sem_res.adb (Resolve_Call): Code reformatting. Do not ask + for the corresponding body before determining the nature of the + ultimate alias's declarative node. + +2014-08-01 Robert Dewar + + * gnat1drv.adb, sem_ch4.adb: Minor reformatting. + +2014-08-01 Robert Dewar + + * sem_eval.adb (Rewrite_In_Raise_CE): Don't try to reuse inner + constraint error node since it is a list member. + +2014-08-01 Robert Dewar + + * sem_warn.adb: Minor reformatting. + +2014-08-01 Eric Botcazou + + * einfo.adb (Underlying_Type): Return the underlying full view + of a private type if present. + * freeze.adb (Freeze_Entity): + Build a single freeze node for partial, full and underlying full + views, if any. + * gcc-interface/decl.c (gnat_to_gnu_entity) : Add a + missing guard before the access to the Underlying_Full_View. + * gcc-interface/trans.c (process_freeze_entity): Deal with underlying + full view if present. + * gcc-interface/utils.c (make_dummy_type): Avoid superfluous work. + +2014-08-01 Ed Schonberg + + * sem_res.adb (Resolve_Entry_Call): When an entry has + preconditions, the entry call is wrapped in a procedure call + that incorporates the precondition checks. To prevent a double + expansion, with possible duplication of extra formals, that + procedure call must only be pre-analyzed and resolved. Expansion + takes place upon return to the caller Resolve_Call. + +2014-08-01 Hristian Kirtchev + + * sem_res.adb (Resolve_Call): Do not perform + GNATprove-specific inlining while within a generic. + +2014-08-01 Ed Schonberg + + * sem_ch4.adb (Analyze_Case_Expression): Handle properly a + case expression with incompatible alternatives, when the first + alternative is overloaded. + +2014-08-01 Ed Schonberg + + * sem_res.adb (Check_Parameterless_Call): Use Relocate_Node + to create the name of the parameterless call, rather than + New_Copy, to preserve the tree structure when the name is a + complex expression, e.g. a selected component that denotes a + protected operation, whose prefix is itself a selected component. + +2014-08-01 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Use + Unit_Declaration_Node to retrieve body when inlining, to handle + properly subprogram child units. + +2014-08-01 Robert Dewar + + * sem_attr.adb: Minor reformatting. + +2014-08-01 Vincent Celier + + * debug.adb: Minor documentation addition for -dn switch. + +2014-08-01 Robert Dewar + + * sem_aggr.adb, exp_ch9.adb, sem_prag.adb, sem_util.adb, + sem_attr.adb, sem_eval.ads, sem_cat.adb, sem_ch13.adb: Improve + documentation of Is_Static_Expression vs Is_OK_Static_Expression. + In several places, use the Is_OK version as suggested by the spec. + +2014-08-01 Vincent Celier + + * gnatcmd.adb: Revert last change which was not correct. + +2014-08-01 Hristian Kirtchev + + * freeze.adb (Find_Constant): Ensure that the constant being + inspected is still an object declaration (i.e. not a renaming). + +2014-08-01 Ed Schonberg + + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): a) + An attribute_reference to Loop_Entry denotes an iterator + specification: its prefix is an object, as is the case for 'Old. + b) If the domain of iteration is an expression whose type has + the Iterable aspect defined, this is an iterator specification. + +2014-08-01 Robert Dewar + + * gnatcmd.adb: Minor reformatting. + +2014-08-01 Robert Dewar + + * atree.ads (Info_Messages): New counter. + * err_vars.ads: Minor comment update. + * errout.adb (Delete_Warning_And_Continuations): Deal + with new Info_Messages counter. + (Error_Msg_Internal): ditto. + (Delete_Warning): ditto. + (Initialize): ditto. + (Write_Error_Summary): ditto. + (Output_Messages): ditto. + (To_Be_Removed): ditto. + * erroutc.adb (Delete_Msg): Deal with Info_Messages counter. + (Compilation_Errors): ditto. + * errutil.adb (Error_Msg): Deal with Info_Messages counter. + (Finalize): ditto. + (Initialize): ditto. + * sem_prag.adb (Analyze_Pragma): Minor comment addition. + * gnat_ugn.texi: Document that -gnatwe does not affect info + messages. + +2014-08-01 Robert Dewar + + * debug.adb: Document debug switch -gnatd.Z. + * sem.adb (Semantics): Force expansion on in no or configurable + run time mode. + +2014-08-01 Ed Schonberg + + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): An + unchecked conversion denotes an iterator specification. Such a + conversion will be inserted in the context of an inlined call + when needed, and its argument is always an object. + +2014-08-01 Robert Dewar + + * make.adb, makeutl.ads: Minor reformatting. + * debug.adb, opt.ads: Clarify documentation of Front_End_Inlining and + Back_End_Inlining. + +2014-08-01 Tristan Gingold + + * gnatcmd.adb (GNATCmd): Set AAMP_On_Target using command name. + +2014-08-01 Javier Miranda + + * gnat1drv.adb (Adjust_Global_Switches): Reverse meaning of + -gnatd.z. + * debug.adb: Updating documentation. + * exp_ch6.adb (Expand_Call): Remove assertion. + +2014-08-01 Robert Dewar + + * sem_aggr.adb, sem_ch3.adb, sem_ch5.adb, sem_util.adb, + sem_res.adb: Minor reformatting. + +2014-08-01 Vincent Celier + + * make.adb (Initialize): Set Keep_Temporary_Files to True when + -dn is specified. + * makeusg.adb: Add line for new switch --keep-temp-files. + * makeutl.ads (Keep_Temp_Files_Option): New constant String. + * opt.ads (Keep_Temporary_Files): Document that it is also used + by gnatmake and gprbuild. + * switch-m.adb: Recognize new switch --keep-temp-files. + +2014-08-01 Tristan Gingold + + * sem_ch9.adb (Analyze_Task_Type_Declaration): Move code from ... + * exp_ch9.adb (Make_Task_Create_Call): ... here. + +2014-08-01 Vincent Celier + + * gnat1drv.adb: Do not try to get the target parameters when + invoked with -gnats. + +2014-08-01 Hristian Kirtchev + + * exp_ch7.adb (Find_Last_Init): Nothing to do for an object + declaration subject to No_Initialization. + +2014-08-01 Ed Schonberg + + * sem_aggr.adb (Resolve_Array_Aggregate): Reject choice that + is a subtype with dynamic predicates, or a non-static subtype + with predicates. + * sem_ch3.adb (Analyze_Number_Declaration): Reject qualified + expression if subtype has a dynamic predicate. + (Constrain_Index): Reject subtype indication if subtype mark + has predicates. + (Inerit_Predicate_Flags): Inherit Has_Predicates as well. + (Make_Index): If index is a subtype indication, itype inhereits + predicate flags for subsequent testing. + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): New + procedure Check_Predicate_Use, to reject illegal uses of domains + of iteration that have dynamic predicates. + * sem_res.adb (Resolve_Slice): Reject slices given by a subtype + indication to which a predicate applies. + * sem_util.adb (Bad_Predicated_Subtype_Use): Add guard to + prevent cascaded errors when subtype is invalid. + +2014-08-01 Robert Dewar + + * sem_ch10.adb: Minor reformatting. + +2014-08-01 Ed Schonberg + + * sem_ch6.adb (Same_Generic_Actual): Make function symmetric, + because either type may be a subtype of the other. + +2014-08-01 Vincent Celier + + * makeusg.adb: Add documentation for debug switch -dn. + +2014-08-01 Ed Schonberg + + * sem_dim.adb (Process_Minus, Process_Divide): Label dimension + expression with standard operator and type, for pretty-printing + use, when in ASIS_Mode. When generating code dimensional analysis + is not involved and dimension expressions are handled statically, + and other operators are resolved in the usual way. + +2014-08-01 Ed Schonberg + + * sem_ch3.adb (Build_Derived_Record_Type): Remove setting of + Parent_Subtype in ASIS mode, leads to several failures. + * sem_ch4.adb (Analyze_Selected_Component): In an instance, + if the prefix is a type extension, check whether component is + declared in the parent type, possibly in a parent unit. Needed + in ASIS mode when Parent_Subtype is not set. + +2014-08-01 Robert Dewar + + * sem_prag.adb: Minor reformatting. + * s-regpat.adb: Minor reformatting. + * sem_ch3.adb (Analyze_Object_Declaration): Do not set + Treat_As_Volatile on constants. + +2014-08-01 Tristan Gingold + + * exp_ch9.adb (Make_Task_Create_Call): Improve error message. + +2014-08-01 Ed Schonberg + + * sem_ch10.adb (Analyze_Compilation_Unit): Do not place a + warning on a with_clause created for the renaming of a parent + unit in an explicit with_clause. + +2014-08-01 Ed Schonberg + + * sem_ch13.adb (Analyze_Aspect_Specifications, case Aspect_Import): + Set Is_Imported flag at once, to simplify subsequent legality + checks. Reject the aspect on an object whose declaration has an + explicit initial value. + * sem_prag.adb (Process_Import_Or_Interface): Use original node + to check legality of an initial value for an imported entity. + Set Is_Imported flag in case of error to prevent cascaded errors. + Do not set the Is_Imported flag if the pragma comes from an + aspect, because it is already done when analyzing the aspect. + +2014-08-01 Emmanuel Briot + + * g-regpat.adb (Parse): Add support for non-capturing parenthesis. + +2014-08-01 Robert Dewar + + * sem_ch7.adb, einfo.adb, einfo.ads, sem_ch13.adb: Minor change of + identifier name. + +2014-08-01 Hristian Kirtchev + + * sem_ch3.adb (Analyze_Object_Contract): Enable the volatility + checks when the related variable comes from source. + * sem_res.adb (Resolve_Actuals): Enable the volatility checks + when the related actual parameter comes from source. Update comment. + * freeze.adb (Freeze_Record_Type): Do not freeze the designated + type of an array of pointers when the designated type is + class-wide and its root type is the record being currently frozen. + +2014-08-01 Ed Schonberg + + * sem_ch5.adb (Analyze_Iterator_Specification): Preserve Ekind + of renaming declaration created for domain of iteration. + * sem_aggr.adb (Resolve_Array_Aggregate): Better placement + for error messages on aggregates whose index subtypes have + predicates. The new placement avoids posting messages on previous + subtype declarations rather than on the aggregate itself. + * sem_disp.adb (Is_Inherited_Public_Operation): New predicate for + Add_Dispatching_Operation, to handle properly the overriding of + the predefined operations on controlled types, when the partial + view of a type is not visibly controlled. + +2014-08-01 Ben Brosgol + + * gnat_ugn.texi: Add tutorial on portable fixed-point types as an + appendix. + +2014-08-01 Hristian Kirtchev + + * einfo.adb (Is_Hidden_Non_Overridden_Subprogram): Remove the + assertion check as the attribute is defined for all entities. + (Set_Is_Hidden_Non_Overridden_Subprogram): Remove the assertion + check as the attribute is defined for all entities. + * einfo.ads Update the documentation of attribute + Is_Hidden_Non_Overridden_Subprogram. + * sem_ch7.adb (Install_Package_Entity): No need to check the + entity kind of the Id. + * sem_ch13.adb (Hide_Matching_Homograph): Update the comment on + usage. Ensure that the homographs are of the same entity kind + and not fully conformant. + (Hide_Non_Overridden_Subprograms): Update the comment on usage. + +2014-08-01 Robert Dewar + + * inline.adb: Minor code reorganization. + * sem_ch12.adb, s-tasdeb.ads: Minor reformatting. + +2014-08-01 Robert Dewar + + * inline.adb, s-os_lib.ads: Minor reformatting. + +2014-08-01 Arnaud Charlet + + * s-tasdeb.ads, s-tasdeb.adb (Master_Hook, Master_Completed_Hook): New. + * s-tassta.adb (Task_Wrapper, Vulnerable_Complete_Master): Call new + hooks. + +2014-08-01 Yannick Moy + + * inline.adb (Cannot_Inline): Issue info message instead of + warning for subprograms not inlined in GNATprove mode. + * sem_res.adb (Resolve_Call): Take body into account for deciding + whether subprogram can be inlined in GNATprove mode or not. + +2014-08-01 Claire Dross + + * exp_util.ads (Get_First_Parent_With_Ext_Axioms_For_Entity): Renaming + of Get_First_Parent_With_External_Axiomatization_For_Entity for + shorter. + * sem_ch12.adb (Analyze_Associations): Only call Build_Wrapper + for parameters of packages with external axiomatization. + +2014-08-01 Robert Dewar + + * sem_res.adb: Minor comment addition. + +2014-08-01 Arnaud Charlet + + * s-crtl.ads, i-cstrea.ads, adaint.c, adaint.h, osint.adb, + s-fileio.adb (__gnat_fopen, __gnat_freopen): Remove vms_form parameter, + no longer used. + * s-os_lib.ads: Minor reformatting. + +2014-08-01 Arnaud Charlet + + * exp_attr.adb (Is_Inline_Floating_Point_Attribute): Restore more + completely previous code since only GCC back-ends are prepared + to handle e.g. 'Machine attribute. + * targparm.adb, targparm.ads: Remove remaining refs and + handling of OpenVMS_On_Target, VAX_Float_On_Target and + RTX_RTSS_Kernel_Module_On_Target. + * hostparm.ads (OpenVMS, Max_Debug_Name_Length): Removed, + no longer used. + +2014-08-01 Robert Dewar + + * exp_dist.adb, exp_attr.adb: Minor reformatting. + * sem_ch3.adb, mlib-tgt-specific-hpux.adb, a-direct.ads, + a-synbar-posix.adb, exp_ch9.adb, sem_ch10.adb, sem_prag.adb, + sem_ch12.adb, sem.ads, sem_res.adb, s-exctra.adb, s-soflin.ads, + g-alveop.ads, sem_ch8.adb, vxaddr2line.adb, sem_cat.ads: Remove + improper use of shall. + +2014-08-01 Robert Dewar + + * sem_aggr.adb, exp_atag.adb, layout.adb, nlists.adb, nlists.ads, + exp_attr.adb, exp_ch9.adb, par-ch12.adb, exp_aggr.adb, + exp_ch3.adb: Minor reformatting & code reorganization. + +2014-08-01 Robert Dewar + + * gnat_rm.texi: Remove VMS specific rules for pragma Ident. + * Makefile.rtl, adaint.c, gnat_rm.texi, s-asthan.adb, s-asthan.ads, + s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, s-fvaffl.ads, s-fvagfl.ads, + s-po32gl.adb, s-po32gl.ads, s-vaflop.adb, s-vaflop.ads, s-vmexta.adb, + s-vmexta.ads, sem_vfpt.adb, sem_vfpt.ads, socket.c: Remove VMS specific + code. + * gcc-interface/decl.c, gcc-interface/Makefile.in, + gcc-interface/Make-lang.in: Ditto. Also remove refs to rTX. + +2014-08-01 Pascal Obry + + * s-os_lib.ads: Rename File_Size to Large_File_Size. + +2014-08-01 Robert Dewar + + * a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads, + a-numaux-darwin.adb, a-numaux-darwin.ads, a-numaux.ads, + a-numaux-libc-x86.ads: Fix bad package header comments. + * elists.ads, elists.adb (Append_New_Elmt): New procedure. + * gnat_rm.texi, a-calend.adb, gnatcmd.adb, einfo.adb, einfo.ads, + checks.adb, sem_prag.adb, sem_prag.ads, rtsfind.ads, freeze.adb, + sem_util.adb, sem_attr.adb, exp_dbug.adb, exp_dbug.ads, gnat1drv.adb, + targparm.adb, targparm.ads, exp_ch6.adb, switch-b.adb, s-shasto.ads, + stand.ads, s-auxdec.ads, opt.adb, opt.ads, mlib-tgt.ads, s-fatgen.adb, + s-fatgen.ads, system.ads, snames.ads-tmpl, s-stalib.ads, + s-os_lib.adb: Remove VMS-specific code. + +2014-08-01 Arnaud Charlet + + * exp_attr.adb (Is_Inline_Floating_Point_Attribute): Revert to + previous state in CodePeer_Mode. + +2014-08-01 Robert Dewar + + * hostparm.ads: Put back definition of OpenVMS as False to aid + the transition process. + * sem_ch7.adb: Minor reformatting. + * prj-env.adb: Minor code fix. + * gnat_rm.texi: Complete previous change. + * sem_ch3.adb: Minor reformatting. + * sem_ch6.adb: Minor reformatting. + * sem_elab.adb: Minor reformatting. + * exp_strm.adb: Complete previous change. + +2014-08-01 Vincent Celier + + * sem_warn.adb (Warn_On_Unreferenced_Entity): Do not issue a + warning when a constant is unreferenced and its type has pragma + Unreferenced_Objects. + +2014-08-01 Hristian Kirtchev + + * einfo.adb: Flag2 is now known as + Is_Hidden_Non_Overridden_Subprogram. + (Is_Hidden_Non_Overridden_Subprogram): New routine. + (Set_Is_Hidden_Non_Overridden_Subprogram): New routine. + (Write_Entity_Fields): Output Flag2. + * einfo.ads: New attribute Is_Hidden_Non_Overridden_Subprogram + along with occurrences in entities. + (Is_Hidden_Non_Overridden_Subprogram): New routine and pragma Inline. + (Set_Is_Hidden_Non_Overridden_Subprogram): New routine + and pragma Inline. + * sem_ch7.adb (Install_Package_Entity): Do not enter implicitly + declared non-overriden homographs into visibility. + * sem_ch13.adb (Freeze_Entity_Checks): Hide all + implicitly declared non-overriden homographs. + (Hide_Non_Overridden_Subprograms): New routine. + +2014-08-01 Robert Dewar + + * snames.ads-tmpl, s-os_lib.adb, s-os_lib.ads, s-fileio.adb: Remove + VMS-specific code. + * prj-conf.adb: Minor reformatting. + * xr_tabls.adb (Read_File): Restore code which was enabled on + non VMS platforms before. + * prj-env.adb (Initialize_Default_Project_Path): Ditto. + * sem_ch5.adb: Minor reformatting. + * lib-writ.adb, lib-writ.ads, bindgen.adb, sem_vfpt.adb, + sem_vfpt.ads, ali.adb, ali.ads, opt.ads, bcheck.adb, exp_strm.adb: + Remove VMS-specific code. + +2014-08-01 Vincent Celier + + * make.adb (Await_Compile): Remove loop that was only needed + for VMS. + +2014-08-01 Robert Dewar + + * a-calcon.ads, a-direct.adb, a-dirval-mingw.adb, a-dirval.adb, + a-dirval.ads, a-except-2005.adb, a-excpol-abort.adb, + a-numaux-darwin.ads, a-numaux.ads, bindgen.adb, bindusg.adb, + einfo.adb, einfo.ads, err_vars.ads, errout.ads, errutil.adb, + exp_ch3.adb, exp_ch4.adb, exp_ch7.adb, exp_ch7.ads, fname-uf.adb, + fname.adb, fname.ads, freeze.adb, g-debpoo.adb, g-dirope.ads, + g-excact.ads, g-expect.ads, g-socket.adb, g-socket.ads, g-sothco.ads, + g-traceb.ads, gnat_rm.texi, gnatlink.adb, gnatls.adb, i-cstrea.adb, + krunch.adb, krunch.ads, layout.adb, lib-util.adb, make.adb, + mlib.adb, osint-b.adb, osint-b.ads, osint-c.adb, osint.adb, + osint.ads, output.ads, par.adb, prj-conf.adb, prj-env.adb, + prj-makr.adb, prj-nmsc.adb, prj.adb, prj.ads, repinfo.adb, rtsfind.adb, + rtsfind.ads, s-excmac-gcc.ads, s-fatgen.adb, s-mastop.ads, + s-parame-ae653.ads, s-parame-hpux.ads, s-parame-vxworks.ads, + s-parame.ads, s-soflin.ads, s-stoele.adb, s-tasini.adb, + s-taspri-dummy.ads, s-taspri-hpux-dce.ads, s-taspri-mingw.ads, + s-taspri-posix-noaltstack.ads, s-taspri-posix.ads, + s-taspri-solaris.ads, s-taspri-vxworks.ads, s-trasym.ads, + sem_ch12.adb, sem_ch4.adb, sem_eval.adb, sem_intr.adb, sem_mech.adb, + sem_mech.ads, sem_prag.adb, sem_res.adb, sem_util.adb, sem_util.ads, + sinfo.adb, sinfo.ads, sinput-c.adb, symbols.ads, targparm.adb, + treepr.adb, types.ads, xr_tabls.adb, xr_tabls.ads: Remove VMS + specific code and comments. + +2014-08-01 Ed Schonberg + + * sem_ch5.adb (Analyze_Iterator_Specification): New procedure + Check_Reverse_Iteration, to verify the legality of the Reverse + indicator on various container types, and to detect illegal + reverse iterations on containers that only supoort forward + iteration. + +2014-08-01 Vincent Celier + + * gnatcmd.adb: Remove the VMS specific stuff. Integrate in + procedure GNATCmd the relevant declarations from packages VMS_Cmds + and VMS_Conv. + * gnatcmd.ads: Update comments to remove any trace of VMS + +2014-08-01 Ed Schonberg + + * sem_ch12.adb: sem_ch12.adb (Build_Wrapper): Capture entity for + defaulted actual that is an operator, before building wrapper + for it in GNATprove mode. Restrict construction of wrapper to + actuals that are operators. + +2014-08-01 Vincent Celier + + * vms_conv.adb, vms_conv.ads, vms_data.ads, vms_cmds.ads: Remove VMS + specific packages no longer needed. + +2014-08-01 Pascal Obry + + * s-os_lib.ads (System.CRTL): Move with clause to body. + (File_Size): New type. + (File_Length64): Use it. + (File_Length): Restore previous spec returning a Long_Integer. + * s-os_lib.adb (System.CRTL): Move with clause here. + +2014-08-01 Vincent Celier + + * mlib-prj.adb: Update comments to remove any mention of VMS. + +2014-08-01 Arnaud Charlet + + * ug_words, xgnatugn.adb, gcc-interface/Make-lang.in: Remove + xgnatugn.adb and ug_words. + +2014-08-01 Eric Botcazou + + * exp_attr.adb (Expand_N_Attribute_Reference): Check whether + expansion can be avoid for Machine, Model and Rounding. + (Is_Inline_Floating_Point_Attribute): Return true for Machine + & Model, as well as Rounding if wrapped in a conversion to an + integer type. + * sem_res.adb (Simplify_Type_Conversion): Deal with Rounding as well. + * gcc-interface/gigi.h (fp_arith_may_widen): Declare. + * gcc-interface/utils.c (fp_arith_may_widen): New global variable. + * gcc-interface/misc.c (enumerate_modes): Compute it. + * gcc-interface/trans.c (FP_ARITH_MAY_WIDEN): Delete. + (lvalue_required_for_attribute_p): Deal with Descriptor_Size, + Machine and Model. + (Attribute_to_gnu) : New case. + ): Likewise. + (convert_with_check): Test + fp_arith_may_widen variable. + +2014-08-01 Pascal Obry + + * adaint.h (GNAT_FOPEN): New definition for Windows. + (GNAT_OPEN): Likewise. + (GNAT_STAT): Likewise. + (GNAT_FSTAT): Likewise. + (GNAT_LSTAT): Likewise. + (GNAT_STRUCT_STAT): Likewise. + * adaint.c (__gnat_stat): Fix computation of file size for + Windows. + +2014-08-01 Vincent Celier + + * Makefile.rtl: Minor comment update. + +2014-08-01 Vincent Celier + + * Make-generated.in: Remove dependencies for vms-help. + +2014-08-01 Gary Dismukes + + * makeutl.ads, opt.ads: Minor grammar fixes. + * makeutl.adb: Minor code reorganization. + +2014-08-01 Arnaud Charlet + + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in, + gnatsym.adb: Remove gnatsym (VMS only tool). + +2014-08-01 Ben Brosgol + + * gnat_ugn.texi, projects.texi, xgnatugn.adb: Removed all VMS + conditionalization from gnat_ugn.texi and projects.texi, and updated + (considerably simplified) xgnatugn.adb, to be removed soon. + +2014-08-01 Vincent Celier + + * debug.adb: Remove doc for gnatmake/gprbuild switch -ds. + * make.adb (List_Bad_Compilations): Use Opt.No_Exit_Message + instead of Debug.Debug_Flag_S. + * makeutl.adb (Finish_Program, Fail_Program): Use Opt flag + No_Exit_Message instead of Debug.Debug_Flag_S to suppress exit + error messages. + * makeutl.ads (No_Exit_Message_Option): New constant string + for switch --no-exit-message. + * opt.ads (No_Exit_Message): New Boolean flag, defaulted to False. + * switch-m.adb (Scan_Make_Switches): Recognize new switch + --no-exit-message. + +2014-08-01 Arnaud Charlet + + * exp_vfpt.adb, exp_vfpt.ads: Removed, no longer used. + * gcc-interface/Make-lang.in: Remove exp_vfpt.o + +2014-08-01 Javier Miranda + + * inline.ads (Inlined_Calls, Backend_Calls, + Backend_Inlined_Subps, Backend_Not_Inlined_Subps): Declarations + moved to inline.adb (Cannot_Inline): Update documentation. + (Check_And_Build_Body_To_Inline): Renamed. + (List_Inlining_Info): Subprogram moved here from package exp_ch6. + * inline.adb (Check_Inlining_Restrictions): New local variable. + (Inlined_Calls, Backend_Calls, Backend_Inlined_Subps, + Backend_Not_Inlined_Subps): Declarations moved here + from inline.ads (Number_Of_Statements): Removed. + (Remove_Pragmas): Avoid duplicated version of this subprogram. + (Build_Body_To_Inline): Code cleanup. + (Build_Body_To_Inline.Has_Excluded_Statament): Removed. + (Check_And_Build_Body_To_Inline): Renamed. Code cleanup. + (Check_Body_To_Inline): Removed. + (Generate_Body_To_Inline): Renamed as Generate_Subprogram_Body. + (Has_Excluded_Declaration): No action if not + Check_Inlining_Restrictions. + (Has_Excluded_Statement): No action if not Check_Inlining_Restrictions. + (Initialize): Initialize the lists of inlined calls and subprograms. + (List_Inlining_Info): Subprogram moved here from package exp_ch6. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Update call + to Check_And_Build_Body_To_Inline since it has been renamed as + Check_And_Split_Unconstrained_Function + * exp_ch6.ad[sb] (List_Inlining_Info): Subprogram moved to + package inline. + * gnat1drv.adb Update call to Inline.List_Inlining_Info. + +2014-08-01 Vincent Celier + + * debug.adb: Add documentation for new debug switch -ds. + * make.adb (List_Bad_Compilations): Do not issue any message + when switch -ds is specified. + * makeutl.adb (Fail_Program): Do not issue any message when + -ds is specified. + (Finish_Program): Ditto. + +2014-08-01 Robert Dewar + + * s-exnint.adb, s-exnint.ads, s-wwdwch.ads, s-carsi8.ads, + s-casi32.ads, indepsw.adb, a-timoau.ads, s-explli.adb, s-explli.ads, + s-casi16.ads, s-powtab.ads, g-wistsp.ads, a-ztmoau.adb, + indepsw-gnu.adb, s-imgllb.ads, types.adb, gnat.ads, s-proinf.adb, + indepsw-aix.adb, s-caun64.ads, s-imgllw.ads, s-traces-default.adb, + s-vxwork-x86.ads, s-expllu.adb, s-exnlli.adb, s-exnlli.ads, + s-traces.adb, widechar.ads, stand.adb, s-expint.adb, + s-tratas-default.adb, s-expint.ads, s-geveop.ads, s-caun32.ads, + s-expuns.adb, s-mantis.adb, s-mantis.ads, s-caun16.ads, s-tasinf.adb, + s-memcop.ads, s-dsaser.ads, s-imgbiu.ads, a-szmzco.ads, g-strspl.ads, + s-casi64.ads, g-zstspl.ads, indepsw-mingw.adb, tree_io.adb, + s-boarop.ads, uname.ads, s-fore.adb, s-fore.ads, g-timsta.adb, + g-timsta.ads, s-assert.adb, s-vector.ads, s-tratas.adb, + s-tratas.ads: Minor fix to copyright notices. + +2014-08-01 Eric Botcazou + + * sinfo.ads: Remove long obsolete comment. +2014-08-01 Ed Schonberg + + * sem_util.adb: Add guard to setting of No_Predicate_On_Actual. + * sem_ch3.adb: Minor reformatting. + +2014-08-01 Pascal Obry + + * cstreams.c: Only enable large file support on know supported + platforms. Add missing defines/includes. + +2014-08-01 Ed Schonberg + + * einfo.ads, einfo.adb New flags No_Predicate_On_Actual and + No_Dynamic_Predicate_On_Actual, to enforce the generic contract + on generic units that contain constructs that forbid subtypes + with predicates. + * sem_ch3.adb (Analyze_Subtype_Declaration, Process_Subtype): + Inherit flags indicating the presence of predicates in subtype + declarations with and without constraints. + (Inherit_Predicate_Flags): Utility for the above. + * sem_util.adb (Bad_Predicated_Subtype_Use): In a generic context, + indicate that the actual cannot have predicates, and preserve + warning. In an instance, report error if actual has predicates + and the construct appears in a package declaration. + * sem_ch12.adb (Diagnose_Predicated_Actual): Report error + for an actual with predicates, if the corresponding formal + carries No_Predicate_On_Actual or (in the case of a loop) + No_Dynamic_Predicate_On_Actual. + * sem_ch13.adb (Build_Predicate_Functions); Do not build a + Static_Predicate function if the type is non-static (in the + presence of previous errors), + * sem_ch5.adb (Analyze_Loop_Parameter_Specification): Set flag + No_Dynamic_Predicate_On_Actual in a generic context, to enforce + generic contract on actuals that cannot have predicates. + +2014-08-01 Pascal Obry + + * a-direct.adb (C_Size): Returns an int64. + * osint.adb (System.CRTL): New with clause. + (File_Length.Internal): Returns an int64. + * s-os_lib.ads (File_Length): Returns an int64. + +2014-08-01 Robert Dewar + + * gnatchop.adb, gnatcmd.adb, make.adb, mlib-prj.adb, bindgen.adb, + mlib.ads, butil.adb, clean.adb, binde.adb, gnatls.adb, gnatname.adb, + osint.adb, krunch.adb: Minor reformatting. + +2014-08-01 Robert Dewar + + * inline.adb, inline.ads, fe.h, einfo.adb, einfo.ads, sem_util.adb, + sem_util.ads, exp_ch4.adb, exp_ch11.adb, exp_ch6.adb, cstand.adb, + sem_mech.adb, sem_ch6.adb, sem_ch8.adb, sem_ch11.adb, snames.ads-tmpl: + Remove VMS-specific code. + * gcc-interface/decl.c, gcc-interface/trans.c: Ditto. + +2014-08-01 Arnaud Charlet + + * binde.adb, bindgen.adb, butil.adb, clean.adb, gnatbind.adb, + gnatchop.adb, gnatcmd.adb, gnatls.adb, gnatname.adb, krunch.adb, + make.adb, makeutl.adb, memtrack.adb, mlib-prj.adb, mlib.adb, + mlib.ads, tempdir.adb: Remove VMS handling. + +2014-08-01 Pascal Obry + + * adaint.h, adaint.c (__gnat_file_length): Returns an __int64. + (__gnat_named_file_length): Likewise. + (__gnat_file_length_attr): Likewise. + * a-direct.adb (C_Size): Use size_t as returned type. + * osint.adb (File_Length): Adjust spec for Internal routine + (returns size_t). + * s-os_lib.adb (File_Length): Now returns a CRTL.size_t. + (System.CRTL): With claused moved to spec. + * s-os_lib.ads (System.CRTL): With clause moved to here. + +2014-08-01 Pascal Obry + + * adaint.h, adaint.c (__gnat_open): Added. + * s-crtl.ads (open): Import __gnat_open for large file support. + +2014-08-01 Robert Dewar + + * sem_case.adb (Dup_Choice): Improve message for integer constants. + +2014-08-01 Arnaud Charlet + + * gnatlink.adb: Remove special handling of VMS, RTX and JVM. + +2014-08-01 Pascal Obry + + * adaint.h (GNAT_OPEN): Defines as open64 where supported. + * adaint.c (GNAT_OPEN): Uses new macro where needed. + +2014-07-31 Eric Botcazou + + * gcc-interface/utils.c (lookup_and_insert_pad_type): New function + extracted from... + (maybe_pad_type): ...here. Call it to canonicalize the pad type. + * gcc-interface/gigi.h: Update comment. + +2014-07-31 Javier Miranda + + * debug.adb Remove documentation of -gnatd.k (no longer needed). + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Code cleanup. + * inline.ads (Backend_Inlined_Subps): New + Elist. (Backend_Not_Inlined_Subps): New Elist. + (Has_Excluded_Declaration): Declaration previously located in + * inline.adb (Has_Excluded_Statement): Declaration previously + located in inline.adb + * inline.adb (Has_Single_Return): Moved out of + Build_Body_To_Inline to avoid having duplicated code. + (Number_Of_Statements): New subprogram. + (Register_Backend_Inlined_Subprogram): New subprogram. + (Register_Backend_Not_Inlined_Subprogram): New subprogram. + (Add_Inlined_Subprogram): Register backend inlined subprograms and + also register subprograms that cannot be inlined by the backend. + (Has_Excluded_Declaration): Moved out of Build_Body_To_Inline + to avoid having duplicated code. Replace occurrences of + Debug_Flag_Dot_K by Back_End_Inlining. + * sem_res.adb (Resolve_Call): Code cleanup. + * exp_ch6.adb (Expand_Call): Complete previous patch. Replace + occurrence of Debug_Flag_Dot_K by Back_End_Inlining. + (List_Inlining_Info): Add listing of subprograms passed to the + backend and listing of subprograms that cannot be inlined by + the backend. + * sem_ch12.adb, sem_ch3.adb Replace occurrences of + Debug_Flag_Dot_K by Back_End_Inlining. + +2014-07-31 Robert Dewar + + * nlists.ads: Minor code fix (remove unwise Inline for + List_Length). + +2014-07-31 Arnaud Charlet + + * einfo.adb: Remove VMS specific code. + * exp_attr.adb: Remove VAX specific code. + * set_targ.adb: Remove handling of VAX_Float. + * sem_vfpt.adb: Remove references to Vax_Native. + * sem_attr.adb (Is_VAX_Float): Remove ref to VAX_Native. + +2014-07-31 Robert Dewar + + * sem_ch4.adb: Minor reformatting. + +2014-07-31 Arnaud Charlet + + * gcc-interface/trans.c, gcc-interface/misc.c: Remove references + to VMS. Misc clean ups. + * gcc-interface/Makefile.in (gnatlib-shared-vms): Remove. + +2014-07-31 Robert Dewar + + * cstand.adb, einfo.adb, einfo.ads, errout.adb, exp_attr.adb, + exp_prag.adb, frontend.adb, interfac.ads, + par-prag.adb, s-auxdec.ads, s-filofl.ads, s-fishfl.ads, s-fvadfl.ads, + s-fvaffl.ads, s-fvagfl.ads, s-vaflop.ads, sem_attr.adb, sem_attr.ads, + sem_ch13.adb, sem_ch3.adb, sem_ch8.adb, sem_prag.adb, snames.adb-tmpl, + snames.ads-tmpl: Remove obsolete VMS-specific code. + +2014-07-31 Robert Dewar + + * sem_ch3.adb, sem_ch13.adb: Minor reformatting. + +2014-07-31 Arnaud Charlet + + * a-intnam-linux.ads: Minor: update obsolete comments. + * s-taasde.adb: Minor: fix comment header. + +2014-07-31 Arnaud Charlet + + * s-auxdec-vms-ia64.adb, s-parame-vms-alpha.ads, s-asthan-vms-alpha.adb, + s-tpopde-vms.adb, s-mastop-vms.adb, s-tpopde-vms.ads, s-taprop-vms.adb, + mlib-tgt-vms_common.adb, mlib-tgt-vms_common.ads, s-inmaop-vms.adb, + g-enblsp-vms-alpha.adb, s-ransee-vms.adb, s-osprim-vms.adb, + s-osprim-vms.ads, g-socthi-vms.adb, g-socthi-vms.ads, system-vms_64.ads, + s-osinte-vms.adb, s-osinte-vms.ads, g-eacodu-vms.adb, + s-vaflop-vms-alpha.adb, s-parame-vms-ia64.ads, a-dirval-vms.adb, + a-caldel-vms.adb, mlib-tgt-specific-vms-alpha.adb, s-tasdeb-vms.adb, + symbols-vms.adb, a-intnam-vms.ads, g-expect-vms.adb, + symbols-processing-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb, + s-traent-vms.adb, s-traent-vms.ads, i-cstrea-vms.adb, a-numaux-vms.ads, + symbols-processing-vms-ia64.adb, s-interr-vms.adb, s-memory-vms_64.adb, + s-memory-vms_64.ads, g-enblsp-vms-ia64.adb, s-taspri-vms.ads, + s-auxdec-vms_64.ads, s-intman-vms.adb, s-intman-vms.ads, + s-tpopsp-vms.adb, s-asthan-vms-ia64.adb, a-calend-vms.adb, + a-calend-vms.ads, system-vms-ia64.ads, s-auxdec-vms-alpha.adb: Removed. + * namet.h (Is_Non_Ada_Error): Remove. + +2014-07-31 Robert Dewar + + * exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor + reformatting. + +2014-07-31 Hristian Kirtchev + + * exp_attr.adb (Expand_Loop_Entry_Attribute): Update the comment + which demonstrates the expansion of while loops subject to + attribute 'Loop_Entry. The condition of a while loop along with + related condition actions is now wrapped in a function. Instead + of repeating the condition, the expansion now calls the function. + +2014-07-31 Ed Schonberg + + * sem_case.adb (Check_Against_Predicate): Correct off-by-one + error when reporting of missing values in a case statement for + a type with a static predicate. + (Check_Choices): Reject a choice given by a subtype to which a + Dynamic_Predicate applies. + * sem_ch3.adb (Analyze_Subtype_Declaration): Inherit + Has_Dynamic_Predicate_Aspect flag from parent. + +2014-07-31 Ed Schonberg + + * sem_ch13.adb (Analyze_Aspect_Specifications): A predicate + cannot apply to a subtype of an incomplete type. + (Is_Static_Choice): Treat an Others_Clause as static. The + staticness of the expression and of the range are checked + elsewhere. + +2014-07-31 Pascal Obry + + * adaint.h (__gnat_ftell64): Added. + (__gnat_fseek64): Added. + (__int64): Added. + * cstreams.c (__int64): Removed. + +2014-07-31 Pascal Obry + + * a-stream.ads (Stream_Element_Offset): Now a signed 64bit type. + * i-cstrea.ads, s-crtl.ads (fseek64): Offset is always a 64bit value. + (ftell64): Always returns a 64bit value. + * cstreams.c (int64): New definition. + (_FILE_OFFSET_BITS): Set to 64 to enable 64bit offset support. + (__gnat_ftell64): Always returns a 64bit value. The implemenation now + uses ftello() on UNIX. + (__gnat_fseek64): Offset is always a 64bit value. The + implementation now uses fseeko() on UNIX. + * a-ststio.adb, s-direio.adb (Set_Position): Simplify code, + always use fseek64 to set the offset. + (Size): Simplify code, always use fseek64/ftell64. + * s-direio.ads (Count): Now an int64. + * g-socket.ads (Vector_Element): Adjust definition for Length + to be a size_t. This matches the C definition and avoid using + a 64bit integer on 32bit platforms now that Count is always 64bit. + * g-socthi-mingw.adb (Ada.Streams): Removed as not used anymore. + (C_Recvmsg): Change some conversion to account for change in + Vector_Element. + (C_Sendmsg): Likewise. + +2014-07-31 Robert Dewar + + * cstand.adb (Create_Standard): Remove handling of -gnatdm flag. + * debug.adb: Remove documentation of -gnatdm flag. + * gnat1drv.adb (Adjust_Global_Switches): Remove handling of + -gnatdm flag. + +2014-07-31 Arnaud Charlet + + * lib-writ.adb (Write_Unit_Information): Fix case where U = + No_Unit. + +2014-07-31 Claire Dross + + * exp_util.adb, exp_util.ads + (Get_First_Parent_With_External_Axiomatization_For_Entity): + New routine to find the first parent of an entity with + a pragma Annotate (GNATprove, External_Axiomatization). + (Has_Annotate_Pragma_For_External_Axiomatization): New function + to check if a package has a pragma Annotate (GNATprove, + External_Axiomatization). + * einfo.ads, einfo.adb (Is_Generic_Actual_Subprogram): New + flag on the entity for the declaration created for a formal + subprogram in an instance. This is a renaming declaration, + or in GNATprove_Mode the declaration of an expression function + that captures the axiomatization of the actual. + * sem_ch6.adb (Analyze_Expression_Function): For a + Generic_Actual_Subprogram, place body immediately after the + declaration because it may be used in a subsequent declaration + in the instance. + * sem_ch12.adb (Build_Wrapper): Add code to handle instances where + the actual is a function, not an operator. Handle functions with + one and two parameters and binary and unary operators. + +2014-07-31 Pascal Obry + + * cstreams.c (__gnat_is_regular_file_fd): Removed. + * adaint.c (__gnat_is_regular_file_fd): Added. + +2014-07-31 Robert Dewar + + * exp_strm.adb: Minor reformatting. + +2014-07-31 Ed Schonberg + + * sem_ch12.adb (Build_Wrapper): New procedure, subsidiary to + Analyze_Associations, to create a wrapper around operators that + are actuals to formal subprograms. This is done in GNATProve + mode in order to propagate the contracts of the operators to + the body of the instance. + +2014-07-31 Ed Schonberg + + * sem_attr.adb (Analyze_Attribute, case 'Old): The reference is + legal if within an aspect specification for a generic subprogram. + +2014-07-31 Javier Miranda + + * gnat1drv.adb (Back_End_Inlining): Set to false if + Suppress_All_Inlining is set. + * debug.adb: Adding documentation for -gnatd.z. + * inline.adb (Add_Inlined_Body): Extend the -gnatn2 + processing to -gnatn1 for calls to Inline_Always routines. + (Add_Inlined_Subprogram): Remove previous patch. + +2014-07-31 Ed Schonberg + + * sem_ch13.adb (Check_One_Function): Apply properly the static + semantic rules for indexing aspects and the functions they denote. + +2014-07-31 Javier Miranda + + * debug.adb: Complete documentation of -gnatd.z. + +2014-07-31 Bob Duff + + * gnat_ugn.texi: Minor doc fixes. + +2014-07-31 Robert Dewar + + * sem_aggr.adb (Resolve_Array_Aggregate): Fix posting of missing + index value. + +2014-07-31 Tristan Gingold + + * s-unstyp.ads (Packed_Byte): Make this type universal aliasing. + (Packed_Bytes1): Make component aliased. + +2014-07-31 Robert Dewar + + * s-unstyp.ads, s-fileio.adb: Minor reformatting. + +2014-07-31 Robert Dewar + + * inline.adb, gnat1drv.adb, exp_ch6.adb, s-fileio.adb: Minor + reformatting. + +2014-07-31 Eric Botcazou + + * gcc-interface/utils2.c ((build_binary_op): Don't set TREE_THIS_NOTRAP + on array references here, now done more selectively in trans.c. + +2014-07-31 Doug Rupp + + * gcc-interface/misc.c (gnat_init_gcc_fp(): Set flag_errno_math to 0. + +2014-07-31 Hristian Kirtchev + + * sem_util.adb (Is_Effectively_Volatile): New routine. + +2014-07-31 Fedor Rybin + + * gnat_ugn.texi: Document --test-duration option for gnattest. + +2014-07-31 Javier Miranda + Eric Botcazou + + * opt.ads (Back_End_Inlining): New variable which controls + activation of inlining by back-end expansion. + * gnat1drv.adb (Adjust_Global_Switches): Initialize Back_End_Inlining + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not build + the body to be inlined by the frontend if Back_End_Inlining + is enabled. + * exp_ch6.adb (Register_Backend_Call): Moved to inline.adb. + (Expand_Call): If backend inlining is enabled let the backend to + handle inlined subprograms. + * inline.ads (Register_Backend_Call): Moved here from exp_ch6 + * inline.adb (Register_Backend_Call): Moved here from exp_ch6. + (Add_Inlined_Subprogram): Add subprograms when Back_End_Inlining is set. + (Must_Inline): Do not return Inline_Call if Back_End_Inlining is + enabled. + * debug.adb Document -gnatd.z + * fe.h Import Back_End_Inlining variable. + * gcc-interface/utils.c (create_subprog_decl): If Back_End_Inlining is + enabled then declare attribute "always inline" + * gcc-interface/decl.c, gcc-interface/trans.c, + gcc-interface/gigi.h: Add handling of Inline_Always pragma. + +2014-07-31 Robert Dewar + + * a-ngelfu.ads: Minor comment fix. + +2014-07-31 Hristian Kirtchev + + * freeze.adb (Freeze_Record_Type): Replace all calls to + Is_SPARK_Volatile with Is_Effectively_Volatile and update + related comments. + * sem_ch3.adb (Analyze_Object_Contract, Process_Discriminants): + Replace all calls to Is_SPARK_Volatile with + Is_Effectively_Volatile and update related comments. + * sem_ch5.adb (Analyze_Iterator_Specification, + Analyze_Loop_Parameter_Specification): Replace all calls to + Is_SPARK_Volatile with Is_Effectively_Volatile and update + related comments. + * sem_ch6.adb (Process_Formals): Replace all calls to + Is_SPARK_Volatile with Is_Effectively_Volatile and update + related comments. + * sem_ch12.adb (Instantiate_Object): Replace the call to + Is_SPARK_Volatile_Object with Is_Effectively_Volatile_Object + and update related comment. + * sem_prag.adb (Analyze_External_Property_In_Decl_Part, + Analyze_Global_Item): Replace all calls to Is_SPARK_Volatile + with Is_Effectively_Volatile and update related comments. + * sem_res.adb (Resolve_Actuals, Resolve_Entity_Name): Replace + all calls to Is_SPARK_Volatile with Is_Effectively_Volatile and + update related comments. + * sem_util.adb (Has_Enabled_Property, + Variable_Has_Enabled_Property): Replace all calls + to Is_SPARK_Volatile with Is_Effectively_Volatile and + update related comments. + (Is_Effectively_Volatile): New routine. + (Is_Effectively_Volatile_Object): New routine. + (Is_SPARK_Volatile): Removed. + (Is_SPARK_Volatile_Object): Removed. + * sem_util.ads (Is_Effectively_Volatile): New routine. + (Is_Effectively_Volatile_Object): New routine. + (Is_SPARK_Volatile): Removed. + (Is_SPARK_Volatile_Object): Removed. + +2014-07-31 Pascal Obry + + * s-fileio.adb (Open): Make sure a shared file gets inserted into + the global list atomically. This ensures that the file descriptor + won't be freed because another tasks is closing the file. + +2014-07-31 Robert Dewar + + * sem_ch3.adb (Process_Range_Expr_In_Decl): Add comments on + generation of _FIRST and _LAST variables even in GNATprove_Mode. + * gnat_ugn.texi: Minor editing. + * sem_prag.adb (Ensure_Aggregate_Form): Make sure generated + aggregate is marked Comes_From_Source if argument is CFS. + +2014-07-31 Pascal Obry + + * s-fileio.adb: Remove obsolete comment. + +2014-07-31 Vincent Celier + + * a-strbou.ads ("=" (Bounded_String, Bounded_String): Add + overriding keyword before function to avoid error when compiler + is called with -gnatyO (check overriding indicators). + +2014-07-31 Tucker Taft + + * gnat_ugn.texi: Add a paragraph pointing the reader + to the "plugins" example. + +2014-07-31 Hristian Kirtchev + + * freeze.adb (Freeze_Expression): Document the + purpose of the parent chain traversal. + +2014-07-31 Robert Dewar + + * checks.ads, checks.adb (Activate_Overflow_Check): Do not set flag for + unconstrained fpt ops. + +2014-07-31 Pascal Obry + + * s-fileio.adb (Open): Make sure a shared file gets inserted into + the global list atomically. This ensures that the file descriptor + won't be freed because another tasks is closing the file. + +2014-07-31 Vincent Celier + + * projects.texi: Minor spelling error fix. + +2014-07-31 Robert Dewar + + * gnat_rm.texi: Document No_Elaboration_Code_All restriction. + * lib-writ.adb, lib-load.adb: Initialize No_Elab_Code field in unit + information. + * lib.ads, lib.adb (No_Elab_Code): New field in unit information. + * restrict.adb (Process_Restriction_Synonyms): Add handling + of No_Elaboration_Code_All. + * restrict.ads (Process_Restriction_Synonyms): Now handles + No_Elaboration_Code_All. + * sem_ch10.adb (Analyze_Context): Enforce transitive with for + No_Elaboration_Code_All. + * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings): + Handle setting of No_Elab_Code in unit information. Handle + No_Elaboration_Code_All. + * snames.ads-tmpl (Name_No_Elaboration_Code): New name for + pragma processing. + (Name_No_Elaboration_Code_All): New name for pragma processing. + +2014-07-31 Eric Botcazou + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Reject array + types with a null range and use the Esize of the component + instead of its RM_Size to identify appropriate values. + +2014-07-31 Hristian Kirtchev + + * freeze.adb Add with and use clause for Aspects. + (Freeze_Expression): Emit an error when a volatile constant lacks + Boolean aspect Import. + (Has_Boolean_Aspect_Import): New routine. + +2014-07-31 Gary Dismukes + + * exp_util.adb: Minor reformatting. + +2014-07-31 Vincent Celier + + * errutil.adb (Error_Msg): Make sure that all components of + the error message object are initialized. + +2014-07-31 Ed Schonberg + + * sem_ch4.adb (Try_Container_Indexing): If the container type is + class-wide, use specific type to locate iteration primitives. + * sem_ch13.adb (Check_Indexing_Functions): Add legality checks for + rules in RM 4.1.6 (Illegal_Indexing): New diagnostic procedure. + Minor error message reformating. + * exp_ch5.adb (Expand_Iterator_Loop): Handle properly Iterator + aspect for a derived type. + +2014-07-31 Robert Dewar + + * debug.adb: Document debug flag d.X. + +2014-07-31 Ed Schonberg + + * sem_util.ads (Find_Specific_Type): Moved here from exp_disp.adb. + * sem_util.adb (Find_Specific_Type): If type is untagged private, + retrieve full view so that primitive operations can be located. + * exp_disp.adb Move Find_Specific_Type to sem_util. + * exp_ch4.adb (Expand_N_Op_Eq): If operands are class-wide, use + Find_Specific_Type to locate primitive equality. + * exp_util.adb (Make_CW_Equivalent_Type): A class_wide equivalent + type does not require initialization. + * exp_attr.adb (Compile_Stream_Body_In_Scope): Within an instance + body all visibility is established, and the enclosing package + declarations must not be installed. + +2014-07-31 Yannick Moy + + * sem_parg.adb, sem_prag.ads (Collect_Subprogram_Inputs_Outputs): + Make subprogram public. + +2014-07-31 Ed Schonberg + + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): New + predicate Discriminated_Size, to distinguish between private + components that depend on discriminants from those whose size + depends on some other non-static expression. + +2014-07-31 Nicolas Setton + + * g-exptty.adb (Close): Fix binding to Waitpid: use the + tty version. + +2014-07-31 Ed Schonberg + + * sem_ch3.adb (Make_Index): Reject properly the use of 'Length + in a discrete range, when 'range was probably intended. + +2014-07-31 Robert Dewar + + * sem_warn.adb, sem_warn.ads (Has_Junk_Name): Moved from body to spec. + +2014-07-31 Robert Dewar + + * frontend.adb: Minor reformatting. + * sem.adb: Minor reformatting. + * sem_ch6.adb (Analyze_Null_Procedure): Set proper sloc for + identifiers on rewrite. + * par.adb: Minor comment updates. + * a-ngelfu.adb (Cos): Minor simplification. + * par-ch13.adb (Get_Aspect_Specifications): Improve messages + and recovery for bad aspect. + * exp_ch3.adb: Code clean up. + * sem_util.ads: Minor comment correction. + * sem_ch13.adb (Check_Array_Type): Properly handle large types. + * sem_ch3.adb: Code clean up. + * binderr.ads: Minor comment correction. + +2014-07-31 Ed Schonberg + + * exp_disp.adb (Expand_Interface_Conversion): A call whose + prefix is a static conversion to an interface type that is not + class-wide is not dispatching. + +2014-07-31 Robert Dewar + + * inline.adb, s-traceb.adb, s-traceb-hpux.adb, memtrack.adb, + s-traceb-mastop.adb: Minor reformatting. + +2014-07-31 Ed Schonberg + + * exp_ch3.adb (Expand_Record_Extension): In ASIS_Mode perform + expansion, to handle properly visibility of selected components + in instance bodies. + +2014-07-31 Robert Dewar + + * par-ch13.adb (Get_Aspect_Specifications): Set Inside_Depends. + * par-ch2.adb (P_Pragma): Set Inside_Depends. + * par-ch4.adb (P_Simple_Expression): Pass Inside_Depends to + Check_Unary_Plus_Or_Minus. + * scans.ads (Inside_Depends): New flag. + * scng.adb (Scan): Pass Inside_Depends to Check_Arrow. + * style.ads: Add Inside_Depends parameter to Check_Arrow Add + Inside_Depends parameter to Check_Unary_Plus_Or_Minus. + * styleg.adb (Check_Arrow): Handle Inside_Depends case. + (Check_Unary_Plus_Or_Minus): Handle Inside_Depends case. + * styleg.ads: Add Inside_Depends parameter to Check_Arrow Add. + Inside_Depends parameter to Check_Unary_Plus_Or_Minus. + +2014-07-31 Javier Miranda + + * s-vaflop.adb Move the body of function T_To_G before + T_To_D. Required for frontend inlining. + * inline.adb (Has_Excluded_Contract): New subprogram used to + check if a subprogram inlined by the frontend has contracts + which cannot be inlined. + +2014-07-31 Bob Duff + + * s-traceb.adb, s-traceb-hpux.adb, s-traceb-mastop.adb: + (Call_Chain): Add 1 to number of frames to skip, to account for + the fact that there's one more frame on the stack. + * gcc-interface/Makefile.in (s-traceb.o): Adjust rules. + +2014-07-31 Robert Dewar + + * checks.adb (Enable_Overflow_Check): More precise setting of + Do_Overflow_Check flag for division. + +2014-07-31 Eric Botcazou + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Reject packed + array types with implementation type. + +2014-07-31 Hristian Kirtchev + + * sem_ch10.adb (Process_State): Remove local variable Name. Add + local variable Decl. Partially declare an abstract state by + generating an entity and storing it in the state declaration. + * sem_prag.adb (Create_Abstract_State): Fully declare a + semi-declared abstract state. + +2014-07-31 Robert Dewar + + * prj-nmsc.adb: Minor reformatting. + +2014-07-31 Bob Duff + + * s-tasdeb.adb (System.Tasking.Debug): Remove + all usage of the secondary stack from this package. + +2014-07-31 Hristian Kirtchev + + * freeze.adb (Freeze_Expression): Update the loop in charge + of finding a proper insertion place for freeze nodes to handle + N_Expression_With_Actions nodes. + +2014-07-31 Robert Dewar + + * sem_util.adb, a-ngelfu.ads, prj-nmsc.adb, prj-conf.adb: Minor + reformatting. + +2014-07-31 Pascal Obry + + * prj-nmsc.adb: Minor reformatting. + +2014-07-31 Ed Schonberg + + * sem_util.adb (Has_Preelaborable_Initialization): Check that + type is tagged before checking whether a user-defined Initialize + procedure is present. + +2014-07-31 Gary Dismukes + + * a-ngelfu.ads (Sqrt): Augment postcondition. + +2014-07-31 Pascal Obry + + * prj-nmsc.adb (Check_Library_Attributes): An aggegate library + directory and ALI directory must be different than all object + and library directories of aggregated projects. + +2014-07-31 Vincent Celier + + * prj-pars.adb, prj-conf.ads, prj-conf.adb (Locate_Runtime): Move spec + to package body, as it is not called from outside. Remove argument + Project_Tree, no longer used. When runtime cannot be found, + call Raise_Invalid_Config instead of failing the program. + +2014-07-31 Robert Dewar + + * bindgen.adb (Gen_Output_File_Ada): Generate pragma Suppress + (Overflow_Check). + * gnatlink.adb (Process_Args): Remove generation of -gnato0, + no longer needed. + +2014-07-31 Robert Dewar + + * gnat_ugn.texi: Document new switch -gnato0. + * sem_ch3.ads: Minor reformatting. + * gnatlink.adb (Process_Args): Compile bind file with -gnato0 + (we do not want overflow checks when incrementing elaboration + counters). + * einfo.ads: Minor reformatting. + +2014-07-31 Robert Dewar + + * exp_ch5.adb, freeze.adb, exp_ch3.adb: Minor comment correction. + * s-arit64.adb: Minor reformatting. + +2014-07-31 Robert Dewar + + * gnat1drv.adb (Adjust_Global_Switches): Default for overflow + checking is enabled except in GNAT_Mode. + * switch-c.adb (Scan_Front_End_Switches): Implement -gnato0 + (suppress overflow checks). + +2014-07-31 Ed Schonberg + + * exp_ch3.adb (Expand_Freeze_Record_Type): Do not build an + invariant procedure for an internally generated subtype that is + created for an object of a class-wide type. + +2014-07-31 Vincent Celier + + * prj-nmsc.adb, errutil.adb: Make code similar to Errout. + +2014-07-31 Gary Dismukes + + * gnat_rm.texi, sem_aux.ads, einfo.ads, sem_util.ads, sem_ch6.adb, + exp_disp.adb: Minor reformatting. + +2014-07-31 Robert Dewar + + * exp_ch5.adb, sem_ch3.adb, exp_ch7.adb, exp_util.adb, exp_ch9.adb, + sem_ch7.adb, checks.adb, s-exctra.adb, exp_ch6.adb, exp_disp.adb, + exp_dist.adb, sem_ch13.adb, exp_strm.adb, exp_ch3.adb: Minor + reformatting. + +2014-07-31 Robert Dewar + + * sem_ch13.adb: Minor reformatting. + +2014-07-31 Ed Schonberg + + * exp_ch3.adb (Build_Invariant_Checks): If the enclosing record + is an unchecked_union, warn that invariants will not be checked + on components that have them. + +2014-07-31 Robert Dewar + + * freeze.adb (Freeze_Entity): Check for error of + Type_Invariant'Class applied to a untagged type. + * sem_ch6.adb (Analyze_Null_Procedure): Unconditionally rewrite + as null body, so that we perform error checks even if expansion + is off. + +2014-07-31 Ed Schonberg + + * sem_ch13.adb (Build_Invariant_Procedure): If body of procedure + is already present, nothing to do. + * exp_ch3.adb (Build_Component_Invariant_Call): For an access + component, check whether the access type has an invariant before + checking the designated type. + (Build_Record_Invariant_Proc): Change suffix of generated + name to prevent ambiguity when record type has invariants + in addition to those of components, and two subprograms are + constructed. Consistent with handling of array types. + (Insert_Component_Invariant_Checks): Build invariant procedure + body when one has not been created yet, in the case of composite + types that are completions and whose full declarations carry + invariants. + +2014-07-30 Thomas Quinot + + * gnat_rm.texi: Minor doc fixes. + +2014-07-30 Robert Dewar + + * a-rbtgbo.adb, sem_ch13.adb: Minor reformatting. + +2014-07-30 Vincent Celier + + * errutil.adb (Set_Msg_Text): Process tilde ('~'): no processing + of error message. + * prj-nmsc.adb (Locate_Directory): Use a tilde ('~') in the + message to report that a directory cannot be created, to avoid + processing of the directory path that may contains special + insertion characters. + +2014-07-30 Ed Schonberg + + * a-crdlli.ads: Place declaration of Empty_List after full type + declaration for Curosr, to prevent freezing error. + +2014-07-30 Robert Dewar + + * get_targ.adb: Minor code reorganization. + * prj-proc.adb, prj-proc.ads, get_targ.ads, sem_ch6.adb: Minor + reformatting. + +2014-07-30 Ed Schonberg + + * a-cbhase.adb: a-cbhase.adb (Insert): Raise Constraint_Error, + not Program_Error, when attempting to remove an element not in + the set. This is the given semantics for all set containers. + +2014-07-30 Ed Schonberg + + * a-rbtgbo.adb (Delete_Node_Sans_Free): If + element is not present in tree return rather than violating + an assertion. Constraint_Error will be raised in the caller if + element is not in the container. + +2014-07-30 Arnaud Charlet + + * set_targ.adb (Read_Target_Dependent_Values): New subprogram. + (elab body): Add provision for default target config file. + * get_targ.ads, get_targ.adb (Get_Back_End_Config_File): New subprogram. + +2014-07-30 Ed Schonberg + + * a-cbhase.adb (Delete): Raise Constraint_Error, not Program_Error, + when attempting to remove an element not in the set. This is + the given semantics for all set containers. + * a-cborse.adb (Delete): Attempt removal first, to check for + tampering, before checking whether this is an attempt to + delete a non-existing element, and in fthe latter case raise + Constraint_Error. + +2014-07-30 Vincent Celier + + * prj-proc.adb (Recursive_Process): Do not create a new + Project_Id if the project is already in the list of projects of + the tree. + +2014-07-30 Ed Schonberg + + * sem_ch6.adb (Analyze_Function_Return): Reject a return expression + whose type is an incomplete formal type. + (Analyze_Return_Type): Reject a return type that is an untagged + imcomplete formal type. + (Process_Formals): Reject a formal parameter whose type is an + untagged formal incomplete type. + * sem_res.adb (Resolve_Actuals): Reject an actual whose type is + an untagged formal incomplete type. + +2014-07-30 Robert Dewar + + * gnat_ugn.texi: Minor spelling correction. + * makeutl.adb: Minor code reorganization. + * exp_ch4.adb, exp_aggr.adb, exp_ch3.adb: Minor reformatting. + +2014-07-30 Robert Dewar + + * einfo.ads (Has_Unchecked_Union): Document that this is used + to check for illegal Valid_Scalars attribute references. + * exp_attr.adb (Build_Record_VS_Func): New function + (Expand_N_Attribute_Reference, case Valid_Scalars): Call this + function. + * gnat_rm.texi: Document 'Valid_Scalars cannot be applied to + Unchecked_Union Add note on 'Valid_Scalars generating a lot + of code. + * sem_attr.adb (Analyze_Attribute, case Valid_Scalars): Give + error on attempt to apply Valid_Scalars to Unchecked_Union type. + +2014-07-30 Steve Baird + + * exp_ch4.adb (Expand_N_Indexed_Component): Disable optimized handling + of A(I..J)(K) in CodePeer_Mode. + +2014-07-30 Ben Brosgol + + * gnat_ugn.texi: Fix typo. + +2014-07-30 Thomas Quinot + + * lib-writ.ads: document format change. + +2014-07-30 Pascal Obry + + * prj-util.adb (For_Interface_Sources): Do not + include sources from withed externally built projects. + +2014-07-30 Robert Dewar + + * lib.adb: Minor reformatting. + * prj-util.adb: Minor reformatting. + +2014-07-30 Ed Schonberg + + * exp_aggr.adb (Build_Record_Aggr_Code): For an array component + that depends on discriminants, and which is given by an others + clause, create an explicit subtype with the discriminant values + of the enclosing aggregate, because the backend cannot otherwise + retrieve the actual bounds of the array. + +2014-07-30 Fedor Rybin + + * gnat_ugn.texi: Improve gnattest documentation. + +2014-07-30 Pascal Obry + + * makeutl.adb (Insert_Project_Sources): Properly handle sources + that are aggregated. We want to include sources not only part + of libraries but also if part of an aggregated project from an + aggregate library. + * prj.adb (For_Project_And_Aggregated_Context): Properly check + state of root project. + +2014-07-30 Thomas Quinot + + * lib-load.ads: Minor reformatting. + * sinfo.ads (Library_Unit): Update comment. + * lib.ads (Notes): Simplify. The Unit component in Notes_Entry + is redundant. Instead used the pragma Node_Id directly as the + element type. + +2014-07-30 Thomas Quinot + + * lib.adb (Store_Note): Store only notes that do not come from + an instance, and that are in the extended main source unit. + * lib-writ (Write_Unit_Information): Annotations from subunits + must be emitted along with those for the main unit, and they + must carry a specific file name. + * ali.ads (Notes_Record): Use a File_Name_Type instead of a + Unit_Id for the source file containing the pragma, as in the + case of annotations from subunits we might not have a readily + available unit id. + * ali.adb (Scan_ALI): Account for above change in data structure. + +2014-07-30 Vincent Celier + + * makeutl.adb (Insert_Project_Sources): When the library project + is an aggregate Stand-Alone Library, insert in the queue the + Ada interface units, with Closure set to True; + +2014-07-30 Eric Botcazou + + * sem_util.adb: Fix minor typo. + * makeutl.adb: Minor reformatting. + +2014-07-30 Robert Dewar + + * exp_ch7.adb, checks.adb, makeutl.adb, makeutl.ads: Minor reformatting. + +2014-07-30 Yannick Moy + + * checks.ads: Fix typo in comment. + +2014-07-30 Pierre-Marie Derodat + + * sem_util.adb (Set_Debug_Info_Needed): For scalar types, recurse on + entities that materialize range bounds, if any. + +2014-07-30 Vincent Celier + + * projects.texi: Minor spelling fix. + +2014-07-30 Hristian Kirtchev + + * checks.adb (Make_Bignum_Block): Use the new secondary stack + build routines to manage the mark. + * exp_ch7.adb (Create_Finalizer, Expand_Cleanup_Actions): + Use the new secodary stack build routines to manage the mark. + (Insert_Actions_In_Scope_Around): Add new formal parameter + Manage_SS along with comment on its usage. Code and comment + reformatting. Mark and release the secondary stack when the + context warrants it. + (Make_Transient_Block): Update the call + to Insert_Actions_In_Scope_Around to account for parameter Manage_SS. + (Wrap_Transient_Declaration): Remove local variable + Uses_SS. Ensure that the secondary stack is marked and released + when the related object declaration appears in a library level + package or package body. Code and comment reformatting. + * exp_util.ads, exp_util.adb (Build_SS_Mark_Call): New routine. + (Build_SS_Release_Call): New routine. + +2014-07-30 Steve Baird + + * exp_attr.adb: Revert previous change, not needed after all. + +2014-07-30 Vincent Celier + + * makeutl.adb (Queue.Insert_Project_Sources): Insert with + Closure => True for interfaces of Stand-Alone Libraries. + * makeutl.ads (Source_Info (Format => Gprbuild)): Add new + Boolean component Closure, defaulted to False. + +2014-07-30 Yannick Moy + + * sem_res.adb: Fix typo in error message. + +2014-07-30 Robert Dewar + + * sem_ch3.adb (Process_Range_Expr_In_Decl): Use _FIRST/_LAST + as name suffixes rather than L/H for subtype bounds. + * tbuild.ads: Minor comment improvements and fixes + (Make_External_Name): Document that suffix can start with an + underscore. + +2014-07-30 Bob Duff + + * gnat_ugn.texi: Document --rep-clauses switch. + +2014-07-30 Ed Schonberg + + * sem_ch13.adb (Analyze_Aspect_Specifications): Default_Value and + Default_Component_Value can only be specified for scalar type or + arrays of scalar types respectively. This legality check must + be performed at the point the aspect is analyzed, in order to + reject aspect specifications that apply to a partial view. + +2014-07-30 Thomas Quinot + + * freeze.adb: Minor reformatting. + +2014-07-30 Robert Dewar + + * exp_attr.adb (Expand_Attribute, case First/Last): Don't expand in + codepeer mode. + +2014-07-30 Ed Schonberg + + * freeze.adb (Check_Expression_Function): At the freeze point + of an expression function, verify that the expression in the + function does not contain references to any deferred constants + that have no completion yet. + (Freeze_Expression, Freeze_Before): call + Check_Expression_Function. + * a-ciorse.ads: Add Reference_Control_Type to detect tampering. + * a-ciorse.adb: Add Adjust and Finalize routines for + Reference_Control_Type. Use it in the construction of Reference + and Constant_Reference values. + +2014-07-30 Robert Dewar + + * exp_aggr.adb: Update comments. + * a-chtgbo.adb, a-chtgbo.ads, a-cbhase.adb, a-cbhase.ads: Minor + reformatting. + +2014-07-30 Robert Dewar + + * cstand.adb (New_Standard_Entity): New version takes name + string to call Make_Name. + (Create_Standard): Use this routine to set name before setting other + fields. + +2014-07-30 Robert Dewar + + * exp_attr.adb (Expand_Attribute, case First): Rewrite simple + entity reference. + (Expand_Attribute, case Last): Ditto. + * exp_ch3.adb (Constrain_Index): New calling sequence for + Process_Range_Expr_In_Decl. + (Expand_N_Object_Declaration): Avoid setting Is_Known_Valid in one + problematical case. + * sem_ch3.adb (Constrain_Index): New calling sequence for + Process_Range_Expr_In_Decl. + (Set_Scalar_Range_For_Subtype): ditto. + (Process_Range_Expr_In_Decl): Create constants to hold bounds for + subtype. + * sem_ch3.ads (Process_Range_Expr_In_Decl): Add Subtyp parameter. + * sem_eval.adb (Compile_Time_Compare): Make sure we use base + types if we are not assuming no invalid values. + +2014-07-30 Robert Dewar + + * clean.adb: Minor reformatting. + * opt.ads: Minor fix to incorrect comment. + +2014-07-30 Ed Schonberg + + * a-chtgbo.ads, a-chtgbo.adb (Delete_Node_At_Index): New + subprogram, used by bounded hashed sets, to delete a node at + a given index, whose element may have been improperly updated + through a Reference_Preserving key. + * a-cbhase.ads: Add Reference_Control_Type to package Generic_Keys. + * a-cbhase.adb: Add Adjust and Finalize routines for + Reference_Control_Type. + (Delete, Insert): Raise Program_Error, not Constraint_Error, + when operation is illegal. + (Reference_Preserving_Key): Build aggregate for Reference_Control_Type + * a-cmbutr.ads: Add Reference_Control_Type to detect tampering. Add + private with_clause for Ada.Finalization. + * a-cbmutr.adb: Add Adjust and Finalize routines for + Reference_Control_Type. Use it in the construction of Reference + and Constant_Reference values. + +2014-07-30 Robert Dewar + + * sem_ch3.adb, sem_ch3.ads: Minor code reorganization. + +2014-07-30 Pascal Obry + + * clean.adb (Clean_Project): Properly check for directory + existence before trying to enter it. + +2014-07-30 Robert Dewar + + * sem_ch3.ads, prj.ads, prj-nmsc.adb: Minor reformatting. + +2014-07-30 Robert Dewar + + * par-ch5.adb (P_Sequence_Of_Statements): Properly handle + missing semicolon after name. + +2014-07-30 Pascal Obry + + * prj.ads (Gprinstall_Flags): New constant. + * prj-nmsc.adb (Check_Library_Attributes): Do not fails for + missing library dir if Directories_Must_Exist_In_Projects + is false. + +2014-07-30 Bob Duff + + * a-except-2005.adb, a-except.adb: Remove obsolete comments. + * s-traceb.ads: Updagte comments. + +2014-07-30 Robert Dewar + + * checks.adb, a-cihase.adb, a-cihase.ads, a-chtgop.adb, a-chtgop.ads, + a-except.adb, a-except-2005.adb, a-cborse.adb, a-cborse.ads, + a-exexda.adb, a-elchha.adb, exp_aggr.adb, a-cohase.adb: Minor + reformatting. + +2014-07-30 Ed Schonberg + + * a-chtgop.ads, a-chtgop.adb (Delete_Node_At_Index): New + subprogram, used by all versions of hashed sets, to delete a node + whose element has been improperly updated through a Reference_ + Preserving key. + * a-cohase.adb: Remove Delete_Node, use new common procedure + Delete_Node_At_Index. + * a-cihase.ads: Add Reference_Control_Type to package Generic_Keys. + * a-cihase.adb: Add Adjust and Finalize routines for + Reference_Control_Type. + (Reference_Preserving_Key): Build aggregate for + Reference_Control_Type + +2014-07-30 Yannick Moy + + * checks.adb, checks.ads (Determine_Range_R): New procedure to + determine the possible range of a floating-point expression. + +2014-07-30 Ed Schonberg + + * a-cborse.ads: Add Reference_Control_Type to package Generic_Keys. + * a-cborse.adb: Add Adjust and Finalize routines for + Reference_Control_Type. + (Reference_Preserving_Key): Build aggregate for + Reference_Control_Type. + (Delete): Check for tampering, and raise Program_Error (not + Constraint_Error) when attempting to delete an element not in + the set. + (Insert): Ditto. + +2014-07-30 Bob Duff + + * a-elchha.adb, a-except-2005.adb, a-except.adb, a-exexda.adb, + * a-exextr.adb, a-exstat.adb, exp_intr.ads, s-tassta.adb: + Exception_Information is used to produce useful debugging + information for the programmer. However, it was also used to + implement the stream attributes for type Exception_Occurrence. The + latter requires a stable and portable interface, which meant + that we couldn't include a symbolic traceback. A separate set of + routines was used to provide symbolic tracebacks under program + control (i.e. not automatically). The goal of this ticket is + to provide such automatic tracebacks, so the change here is to + split the two functionalities: Exception_Information gives the + maximally useful information for debugging (i.e. it now includes + a symbolic traceback when a decorator is set, and it can be + improved freely in the future without disturbing streaming). + Untailored_Exception_Information always uses hexadecimal addresses + in the traceback, has a stable and portable output, and is now + used for streaming. + +2014-07-30 Eric Botcazou + + * exp_aggr.adb (Expand_Array_Aggregate): Add missing test + on the target of the assignment to find out whether it + can be directly done by the back-end. + * exp_util.adb (Is_Possibly_Unaligned_Slice): Remove obscure test. + +2014-07-30 Robert Dewar + + * inline.adb, a-coorse.adb, a-coorse.ads, a-cohase.adb, a-cohase.ads, + a-tasatt.adb: Minor reformatting. + +2014-07-30 Robert Dewar + + * exp_ch4.adb: Minor reformatting. + +2014-07-30 Ed Schonberg + + * a-coorse.adb, a-coorse.ads (Generic_Keys): Add a + Reference_Control_Type to generic package, to keep additional + information for Reference_Types that manipulate keys. Add Adjust and + Finalize procedures for this type. + (Finalize): When finalizing a reference_preserving_key, verify + that the key of the new value is equivalent to the key of the + original element, raise Program_Error otherwise. + (Insert): Detect tampering. + (Reference_Preserving_Key): Build proper Reference_Control_Type, + and update Busy and Lock bits to detect tampering. + * a-cohase.ads: Keep with-clause private. + +2014-07-30 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Op_Eq): Emit a warning when the operands + of an equality are of an Unchecked_Union type and lack inferable + discriminants. + +2014-07-30 Bob Duff + + * g-exctra.adb, g-exctra.ads, s-exctra.adb, s-exctra.ads, Makefile.rtl, + g-trasym.adb, g-trasym.ads, s-trasym.adb, s-trasym.ads: Move + GNAT.Traceback.Symbolic and GNAT.Exception_Traces into the System + hierarchy (System.Traceback.Symbolic and System.Exception_Traces), so + we can call them from the runtimes. Leave renamings in place under GNAT. + +2014-07-30 Yannick Moy + + * inline.adb (Check_And_Build_Body_To_Inline): Include code for + inlining in GNATprove mode. + +2014-07-30 Ed Schonberg + + * a-cohase.adb, a-cohase.ads (Generic_Keys): Add a + Reference_Control_Type to generic package, to keep additional + information for Reference_Types that manipulate keys. Add Adjust and + Finalize procedures for this type. + (Delete_Node): New procedure called when finalizing a + Reference_Control_Type, to remove a node whose element has been + improperly updated through a Reference. + (Insert): Detect tampering. + (Reference_Preserving_Key): Build proper Reference_Control_Type, + and update Busy and Lock bits to detect tampering. + +2014-07-30 Bob Duff + + * exp_intr.ads: Minor comment fix. + +2014-07-30 Gary Dismukes + + * exp_prag.adb, a-tags.ads: Minor typo fixes. + +2014-07-30 Bob Duff + + * a-excach.adb, a-excach-cert.adb, a-except-2005.ads, + a-except.ads, g-traceb.adb, memtrack.adb, + s-traceb.adb, s-traceb.ads, s-traceb-hpux.adb, s-traceb-mastop.adb: + Cleanup: Make the three versions of System.Traceback.Call_Chain + have the same interface. Use an array for the Traceback parameter + instead of an Address. This will enable reduction in code + duplication. + +2014-07-30 Pat Rogers + + * gnat_ugn.texi: Corrected minor textual error in description + of switch -gnatwl. + +2014-07-30 Bob Duff + + * Makefile.rtl: Sort file names. + +2014-07-30 Arnaud Charlet + + * a-tasatt.adb: Complete previous change: kill spurious warning + on e.g. sparc, and make sure we only use the fast path when the + alignment is compatible. + +2014-07-30 Yannick Moy + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Mark new Spec_Id as + coming from source. + +2014-07-30 Yannick Moy + + * inline.adb (Build_Body_To_Inline): Issue more precise messages + for declarations that prevent inlining. + (Cannot_Inline): Change usual start of message to refer to contextual + analysis in GNATprove mode. + * sem_res.adb (Resolve_Call): Change usual start of message to + refer to contextual analysis in GNATprove mode, when inlining + not possible. + +2014-07-30 Robert Dewar + + * sem_res.adb, sem_ch6.adb: Minor code reorganization. + * inline.adb: Minor reformatting. + +2014-07-30 Javier Miranda + + * a-tags.ads: Add comments. + +2014-07-30 Pat Rogers + + * gnat_rm.texi: Minor word error. + +2014-07-30 Ed Schonberg + + * exp_prag.adb (Expand_Old): Insert declarationss of temporaries + created to capture the value of the prefix of 'Old at the + beginning of the current declarative part, to prevent data flow + anomalies in the postcondition procedure that will follow. + +2014-07-30 Yannick Moy + + * debug.adb: Retire debug flag -gnatdQ. + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Check SPARK_Mode + on decl, not on body. Ignore predicate functions. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Remove use of + debug flag -gnatdQ. Correctly analyze SPARK_Mode on decl and + body when generating a decl for a body on which SPARK_Mode aspect + is given. + * sem_prag.adb (Analyze_Pragma|SPARK_Mode): Reorder tests for + attaching pragma to entity, to account for declaration not coming + from source. + * sem_res.adb (Resolve_Call): Issue warning and flag subprogram + as not always inlined in GNATprove mode, when called in an + assertion context. + +2014-07-30 Vincent Celier + + * debug.adb: Minor comment update. + +2014-07-30 Robert Dewar + + * s-tasuti.adb, s-tassta.adb: Minor reformatting. + * sprint.adb (Sprint_Node): Handle N_Contract case. + * exp_prag.adb: Minor reformatting. + * freeze.adb (Freeze_Entity): Check useless postcondition for + No_Return subprogram. + * sem_prag.adb: Minor reformatting. + +2014-07-30 Javier Miranda + + * a-tags.ads: Complete comments about performance. + +2014-07-30 Fedor Rybin + + * gnat_ugn.texi: Adding description for --exit-status option to + gnattest section. Fixing index entry of --passed-tests option + in gnattest section. + +2014-07-30 Javier Miranda + + * Makefile.rtl, gnat_rm.texi, i-cpp.adb, i-cpp.ads, impunit.adb, + rtsfind.ads: Remove references to package Interfaces.CPP since this + package is no longer needed. + +2014-07-30 Bob Duff + + * s-taasde.adb (Timer_Queue): Don't use a + build-in-place function call to initialize the Timer_Queue. + * s-traent.adb, s-traent.ads, s-traent-vms.adb, s-traent-vms.ads: + Turn off polling in these units, because otherwise we get + elaboration circularities with Ada.Exceptions when the -gnatP + switch is used. + * s-tassta.adb (Create_Task): Make sure independent tasks + are created with Parent = Environment_Task. This was not true, + for example, in s-interr.adb, when Interrupt_Manager does "new + Server_Task"; the Server_Task had Parent = Interrupt_Manager, + which is wrong because the master is determined by the access + type, which is at library level. + * s-tasuti.adb (Make_Independent): Avoid setting Parent; it is + now set correctly by Create_Task. + (Make_Passive): Remove the workaround for the race condition in + Make_Independent. + * frontend.adb (Frontend): Revert to previous method of detecting + temporary configuration pragma files, recognizing such files by + ".tmp" in the name. This is more general than detecting pragmas + Source_File_Name_Project, because it allows any tool to use + this naming convention, no matter the content of the file. + * gnat_ugn.texi: Document this naming convention. + +2014-07-30 Robert Dewar + + * exp_ch7.adb, s-tataat.adb, s-tataat.ads, s-parame-vms-alpha.ads, + inline.adb, s-parame-hpux.ads, exp_smem.adb, s-tasini.adb, + s-tasini.ads, s-parame-vms-ia64.ads, s-parame.ads, s-taskin.ads, + s-parame-vxworks.ads, a-tasatt.adb, a-tasatt.ads: Minor reformatting. + * a-suenco.adb (Convert): Handle overlong encodings in UTF8-UTF8 + conversion. + +2014-07-30 Ed Schonberg + + * sem_ch5.adb: Improve error recovery. + * inline.adb (Build_Body_To_Inline): Set Full_Analysis to false + before analyzing the body, so that in GNATprove mode there is + no light expansion. Whatever expansion is required by SPARK will + be performed when analysing the inlined code. + +2014-07-30 Bob Duff + + * s-tataat.adb, s-tataat.ads, a-tasatt.adb: Minor comment fixes. + +2014-07-30 Ed Schonberg + + * sem_ch5.adb (Analyze_Loop_Statement): If loop has a label, + verify that it is not hidden by an inner implicit declaration. + +2014-07-30 Thomas Quinot + + * sem.ads (Scope_Table_Entry): New component Locked_Shared_Objects. + * sem_ch8.adb (Push_Scope): Initialize Locked_Shared_Objects. + * exp_smem.adb (Add_Shared_Var_Lock_Procs): Handle the case where + the call returns an unconstrained type: in this case there is + already a transient scope, and we should not establish a new one. + * exp_ch7.adb (Insert_Actions_In_Scope_Around): New formal Clean. If + True, also insert cleanup actions in the tree. + (Wrap_Transient_Declaration): Call Insert_Actions_In_Scope_Around + with Clean set True. + +2014-07-30 Arnaud Charlet + + * s-taskin.ads (Direct_Index, Direct_Index_Range, + Direct_Attribute_Element, Direct_Attribute_Array, + Direct_Index_Vector, Direct_Attributes, Is_Defined, + Indirect_Attributes): Removed. (Atomic_Address, + Attribute_Array, Attributes): New. + * s-tasini.ads, s-tasini.adb (Proc_T, Initialize_Attributes, + Finalize_Attributes_Link, Initialize_Attributes_Link): Removed. + (Finalize_Attributes): Reimplement. + * s-tassta.adb (Create_Task): Remove call to + Initialize_Attributes_Link (Free_Task, Vulnerable_Free_Task): + Replace Finalize_Attributes_Link by Finalize_Attributes. + * a-tasatt.ads, a-tasatt.adb, s-tataat.ads, s-tataat.adb: + Reimplement from scratch, using a simpler and more efficient + implementation. + * s-tporft.adb (Register_Foreign_Thread): Remove now obsolete comment. + * s-parame.ads, s-parame-hpux.ads, + * s-parame-vms-alpha.ads, s-parame-vms-ia64.ads, + * s-parame-vxworks.ads (Max_Attribute_Count): New, replace + Default_Attribute_Count. + +2014-07-30 Olivier Hainque + + * vxworks-ppc-link.spec: New file. Extra link + instructions for ppc-vxworks. + * vxworks-crtbe-link.spec: Likewise, for ZCX related support. + * system-vxworks-ppc.ads: Adjust linker options to use spec files. + * system-vxworks-arm.ads: Likewise. + * gcc-interface/Makefile.in: Enable .spec files. + +2014-07-30 Ed Schonberg + + * sem_aggr.adb: Minor comment reformatting. + +2014-07-30 Robert Dewar + + * sem_util.ads, sem_util.adb (Is_Junk_Name): Removed. + * sem_warn.adb (Has_Junk_Name): New function + (Check_References): Use Has_Junk_Name to delete junk warnings + (Check_Unset_Reference): ditto. + (Warn_On_Unreferenced_Entity): ditto. + (Warn_On_Useless_Assignment): ditto. + +2014-07-30 Ed Schonberg + + * checks.adb (Insert_Valid_Check): Do not check for the packed + array type of a prefix that is an access type. + +2014-07-30 Ed Schonberg + + * sem_attr.adb (Eval_Attribute): Evaluate the GNAT attribute + Unconstrained_Array even if prefix is not frozen yet, as can + occur with a private subtype used as a generic actual. + +2014-07-30 Gary Dismukes + + * sem_attr.adb: Minor reformatting. + +2014-07-30 Pat Rogers + + * gnat_rm.texi: Corrected minor wording error in description + of No_Exception_Registration. + +2014-07-30 Yannick Moy + + * einfo.ads, einfo.adb: New flag Is_Inlined_Always for use in GNATprove + mode. Realphabetize two subprograms. + * inline.adb (Cannot_Inline): Use Is_Inlined_Always in GNATprove mode. + (Can_Be_Inlined_In_GNATprove_Mode): Adapt to possible Empty Body_Id. + (Check_And_Build_Body_To_Inline): Use Is_Inlined_Always in GNATprove + mode. + (Expand_Inline_Call): Use Is_Inlined_Always in GNATprove mode. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Do not use + Is_Inline in GNATprove mode. + (Analyze_Subprogram_Specification): + Set Is_Inlined_Always at subprogram entity creation. + * sem_res.adb (Resolve_Call): Do not deal with inlining during + pre-analysis. Issue warning on call to possibly inlined + subprogram when body not seen. + +2014-07-30 Yannick Moy + + * lib-xref.adb (Generate_Reference): Add special + case for compiler-generated formals in GNATprove mode. + +2014-07-30 Yannick Moy + + * sem_ch6.adb: Add comments. + +2014-07-30 Thomas Quinot + + * s-os_lib.ads (GM_Time_Of): Clarify documentation. + +2014-07-30 Robert Dewar + + * sem_aggr.adb, sem_res.adb: Minor reformatting. + +2014-07-30 Thomas Quinot + + * sem_ch13.adb (Analyze_Attribute_Definition_Clause, case + Bit_Order): Set Reverse_Bit_Order on the base type of the + specified first subtype. + +2014-07-30 Ed Schonberg + + * inline.adb (Expand_Inlined_Call): Use a renaming declaration + to capture the value of actuals of a limited type rather than + an object declaration, to prevent spurious errors when analyzing + the inlined body. + +2014-07-30 Ed Schonberg + + * sem_ch4.adb (Analyze_Type_Conversion): Treat an inlined body + as an instance, and inhibit semantic checks on already analyzed + code to prevent spurious errors. + +2014-07-30 Arnaud Charlet + + * a-exctra.ads ("="): New function, to restore compatibility. + +2014-07-30 Pascal Obry + + * adaint.c (__gnat_to_os_time): Set isdst to -1 for the mktime + routine to use the OS dst setting. + +2014-07-30 Pat Rogers + + * gnat_ugn.texi: Minor correction to description of -gnatw.K. + +2014-07-30 Ed Schonberg + + * sem_util.adb (Wrong_Type): Disable some checks equally within + instances and within inlined bodies, to suppress spurious type + errors on already analyzed code. + * sem_aggr.adb (Check_Expr_OK_In_Limited_Aggregate): Expression + is legal in an inlined body, juts as it is in an instance body. + +2014-07-30 Ed Schonberg + + * sem_res.adb (Resolve_Unchecked_Conversion): Within an inlined + body the operand of an unchecked conversion may be a literal, in + which case its type is the target type of the conversion. This + is in contrast to conversions in other contexts, where the + operand cannot be a literal and must be resolvable independent + of the context. + +2014-07-30 Pierre-Marie Derodat + + * gcc-interface/decl.c (gnat_to_gnu_entity) : Create a + mere scalar constant instead of a reference for a renaming of + scalar literal. + * gcc-interface/utils.c (renaming_from_generic_instantiation_p): New. + * gcc-interface/gigi.h (renaming_from_generic_instantiation_p): New. + +2014-07-30 Robert Dewar + + * s-tasuti.adb, s-tasuti.ads, einfo.ads, sem_prag.adb, s-taasde.adb, + g-socthi-vms.adb, s-taprop-mingw.adb, s-interr.adb, s-interr-hwint.adb, + g-decstr.adb, s-tasdeb-vms.adb, g-expect-vms.adb, makeutl.adb, + s-interr-vms.adb, g-socthi.adb, exp_aggr.adb, s-tasdeb.adb, + g-awk.adb, gnatls.adb, s-taspri-posix.ads, g-catiio.adb, + s-interr-sigaction.adb, s-os_lib.adb, s-fileio.adb: Minor reformatting + & code reorganization. + +2014-07-30 Bob Duff + + * s-tassta.adb, sem_util.ads: Minor reformatting. + +2014-07-30 Yannick Moy + + * inline.adb (Build_Body_To_Inline): Detect when + subprogram has multiple returns, or not a single last return + statement, in GNATprove mode. + (Cannot_Inline): Simplify logic to handle case of GNATprove + inlining first. + +2014-07-30 Ed Schonberg + + * sem_ch6.adb: Stubs are not subject to inlining. + +2014-07-30 Bob Duff + + * s-tasuti.ads, s-tasuti.adb (Make_Independent): Change this + from a procedure to a function, so that it can more easily be + called before the "begin" of a task. + * s-taasde.ads (Delay_Block): Make this type immutably limited, + so we can use a build-in-place function call to initialize + Timer_Queue in the body. + * a-rttiev.adb, s-asthan-vms-alpha.adb, s-asthan-vms-ia64.adb, + * s-interr.adb, s-interr-hwint.adb, s-interr-sigaction.adb, + * s-interr-vms.adb, s-taasde.adb: Each independent task now calls + Make_Independent before reaching its "begin", to avoid race + conditions. This causes the activating task to wait until after + Make_Independent is complete before proceeding. In addition, + we initialize data structures used by independent tasks before + activating those tasks, to avoid possible use of uninitialized data. + * s-interr.ads, s-intman.ads, s-taspri-posix.ads, s-tasdeb.ads: + Minor comment fixes. + +2014-07-30 Bob Duff + + * a-exctra.ads, s-traent-vms.ads, s-traent.ads (Tracebacks_Array): Move + the declaration of Tracebacks_Array from Ada.Exceptions.Traceback to + System.Traceback_Entries (s-traent.ads and s-traent-vms.ads). Add + subtypes renaming Tracebacks_Array in Ada.Exceptions.Traceback. + * g-debpoo.adb: Refer to Tracebacks_Array in its new home. + +2014-07-30 Arnaud Charlet + + * a-tasatt.adb: Remove old comments. + +2014-07-30 Yannick Moy + + * einfo.ads (Is_Inlined): Document new use in GNATprove mode. + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): Add comments + to explain rationale for inlining or not in GNATprove mode. + (Expand_Inlined_Call): In GNATprove mode, set Is_Inlined flag + to False when inlining is not possible. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Is_Inlined + flag to indicate that subprogram is fully inlined. To be reversed + if inlining problem is found. + * sem_res.adb (Resolve_Call): Set Is_Inlined flag to False when + call in potentially unevaluated context. + +2014-07-30 Jose Ruiz + + * s-tarest.adb, s-tarest.ads: Fix comments. + +2014-07-30 Robert Dewar + + * exp_attr.adb, checks.adb, sem_util.adb, sem_util.ads, sem_attr.adb: + Change No_Scalar_Parts predicate to Scalar_Part_Present and + invert sense of test. This avoids the "not No_xxx" situation + which is always ugly. + +2014-07-30 Ed Schonberg + + * inline.adb (Expand_Inlined_Call): When generating code for + an internal subprogram the expansion uses the location of the + call, so that gdb can skip over it. In GNATprove mode we want to + preserve slocs of original subprogram when expanding an inlined + call, to obtain better warnings, even though subprogram appears + not to come from source if it is the inlining of a subprogram + body without a previous spec. + +2014-07-30 Eric Botcazou + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): Reject array + types with atomic components. + +2014-07-30 Thomas Quinot + + * Make-generated.in: Remove now unnecessary targets after s-oscons + reorg. + +2014-07-30 Yannick Moy + + * sem_res.adb (Resolve_Call): Use ultimate alias + of callee when available. + +2014-07-30 Ed Schonberg + + * sem_ch6.adb (Analyze_Expression_Function): To check whether + an expression function is a completion, use the specification of + the previous declaration, not its entity, which may be internally + generated in an inlined context. + +2014-07-30 Doug Rupp + + * adaint.c (__gnat_tmp_name) [__ANDROID__]: Default to putting + temp files in /cache directory unless overridden by TMPDIR. + +2014-07-30 Jose Ruiz + + * s-tassta.adb, s-tarest.adb (Initialize, Create_Task, + Create_Restricted_Task): Remove redundant check. Number_Of_CPUs returns + type CPU, so it can never be greater than CPU_Range'Last. + +2014-07-30 Bob Duff + + * s-taskin.ads: Minor comment fix. + +2014-07-30 Thomas Quinot + + * g-socket.adb: Remove now useless WITH, USE, and USE TYPE + clauses. + +2014-07-30 Yannick Moy + + * debug.adb: Free debug flag dQ used for frontend inlining in + GNATprove mode.. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Remove test of + debug flag.. + +2014-07-30 Thomas Quinot + + * Make-generated.in: Remove generation of s-oscons.ads, only + generate the xoscons utility, in runtime-agnostic rules. + * gcc-interface/Makefile.in: Clean up rules. Remove VMS parts, + no longer supported. + +2014-07-30 Bob Duff + + * exp_ch6.adb (Add_Task_Actuals_To_Build_In_Place_Call): New + parameter Chain to be used in the allocator case. + (Make_Build_In_Place_Call_In_Allocator): If the allocated object + has tasks, wrap the code in a block that will activate them, + including the usual finalization code to kill them off in case + of exception or abort. + +2014-07-30 Robert Dewar + + * treepr.adb, treepr.ads; Reorganize documentation for new pp routines + Remove renamings (don't work for gdb). + (par): New synonym for p (avoid gdb ambiguities). + * inline.adb, sem_ch6.adb, sem_ch13.adb: Minor reformatting. + +2014-07-30 Bob Duff + + * exp_ch9.ads, sem_prag.adb, exp_ch4.adb, sem_ch13.adb: Minor comment + fixes. + * treepr.ads, treepr.adb (ppp): Make this debugging routine + accept any type covered by Union_Id. + +2014-07-30 Robert Dewar + + * sem_ch4.adb (Analyze_If_Expression): Resolve condition before + analyzing branches. + * sem_eval.adb (Out_Of_Range): Check for statically unevaluated + expression case. + +2014-07-30 Robert Dewar + + * sem_ch13.adb (Analyze_Aspect, predicate cases): Diagnose use + of predicate aspect on entity other than a type. + +2014-07-30 Ed Schonberg + + * sem_ch6.adb (Body_Has_Contract): New predicate to determine + when a subprogram body without a previous spec cannot be inlined + in GNATprove mode, because it includes aspects or pragmas that + generate a SPARK contract clause. + * inline.adb (Can_Be_Inlined_In_GNATprove_Mode): A subprogram + instance cannot be inlined. + +2014-07-30 Robert Dewar + + * debug.adb: Document that d7 suppresses compilation time output. + * errout.adb (Write_Header): Include compilation time in + header output. + * exp_intr.adb (Expand_Intrinsic_Call): Add + Compilation_Date/Compilation_Time (Expand_Source_Info): Expand + Compilation_Date/Compilation_Time. + * g-souinf.ads (Compilation_Date): New function + (Compilation_Time): New function. + * gnat1drv.adb (Gnat1drv): Set Opt.Compilation_Time. + * gnat_rm.texi (Compilation_Date): New function + (Compilation_Time): New function. + * opt.ads (Compilation_Time): New variable. + * s-os_lib.ads, s-os_lib.adb (Current_Time_String): New function. + * sem_intr.adb (Compilation_Date): New function. + (Compilation_Time): New function. + * snames.ads-tmpl (Name_Compilation_Date): New entry. + (Name_Compilation_Time): New entry. + +2014-07-30 Yannick Moy + + * inline.adb: Add comment. + +2014-07-30 Ed Schonberg + + * par-ch4.adb (Is_Parameterless_Attribute): 'Result is a + parameterless attribute, and a postondition can mention an + indexed component or a slice whose prefix is an attribute + reference F'Result. + +2014-07-30 Robert Dewar + + * sprint.adb (Sprint_Node_Actual, case Object_Declaration): + Avoid bomb when printing package Standard. + +2014-07-30 Ed Schonberg + + * sem_elab.adb (Check_Internal_Call_Continue): If an elaboration + entity is created at this point, ensure that the name of the + flag is unique, because the subprogram may be overloaded and + other homonyms may also have elaboration flags created on the fly. + +2014-07-30 Hristian Kirtchev + + * sem_attr.adb (Analyze_Array_Component_Update): New routine. + (Analyze_Attribute): Major cleanup of attribute + 'Update. The logic is now split into two distinct routines + depending on the type of the prefix. The use of <> is now illegal + in attribute 'Update. + (Analyze_Record_Component_Update): New routine. + (Check_Component_Reference): Removed. + (Resolve_Attribute): Remove the return statement and ??? comment + following the processing for attribute 'Update. As a result, + the attribute now freezes its prefix. + +2014-07-30 Javier Miranda + + * exp_ch4.adb (Apply_Accessibility_Check): Do + not call Base_Address() in VM targets. + +2014-07-30 Yannick Moy + + * gnat1drv.adb (Adjust_Global_Switches): Set + Ineffective_Inline_Warnings to True in GNATprove mode. + * inline.adb (Cannot_Inline): Prepare new semantics for GNATprove + mode of inlining. + * opt.ads (Ineffective_Inline_Warnings): Add comment that + describes use in GNATprove mode. + * sem_prag.adb (Analyze_Pragma|SPARK_Mode): Ignore + pragma when applied to the special body created for inlining. + +2014-07-30 Robert Dewar + + * inline.adb, exp_ch4.adb, sinput.adb, sem_ch6.adb, sem_ch13.adb: + Minor reformatting. + +2014-07-30 Hristian Kirtchev + + * aspects.ads Add a comment explaining why SPARK 2014 aspects are + not delayed. Update the delay status of most SPARK 2014 aspects. + * sem_ch13.adb (Analyze_Aspect_Specifications): Update all calls + to Decorate_Aspect_And_Pragma and Insert_Delayed_Pragma to refert + to Decorate and Insert_Pragma. Add various comments concerning + the delay status of several SPARK 2014 aspects. The insertion + of Refined_State now uses routine Insert_After_SPARK_Mode. + (Decorate): New routine. + (Decorate_Aspect_And_Pragma): Removed. + (Insert_Delayed_Pragma): Removed. + (Insert_Pragma): New routine. + +2014-07-30 Ed Schonberg + + * inline.adb (Expand_Inlined_Call): In GNATprove mode, emit + only a warning, not an error on an attempt to inline a recursive + subprogram. + +2014-07-30 Robert Dewar + + * g-forstr.adb: Minor code reorganization (use J rather than I + as a variable name). + * gnat_rm.texi, sem_prag.adb, sem_util.adb, sem_ch13.adb, + g-forstr.ads: Minor reformatting. + +2014-07-30 Eric Botcazou + + * sprint.adb (Set_Debug_Sloc): Also reset the end location if + we are debugging the generated code. + +2014-07-30 Yannick Moy + + * sinput.ads, sinput.adb (Comes_From_Inlined_Body): New function that + returns True for source pointer for an inlined body. + +2014-07-30 Javier Miranda + + * exp_ch4.adb (Apply_Accessibility_Check): Add + missing calls to Base_Address(). + +2014-07-30 Ed Schonberg + + * sem_ch6.adb (Hanalyze_Subprogram_Body_Helper): In GNATprove + mode, subprogram bodies without a previous declaration are also + candidates for front-end inlining. + +2014-07-30 Hristian Kirtchev + + * aspects.ads Aspects Async_Readers, Async_Writers, + Effective_Reads and Effective_Writes do not need to be delayed. + * sem_ch13.adb (Analyze_Aspect_Specifications): Propagate the + optional Boolean expression when generating the corresponding + pragma for an external property aspect. + * sem_prag.adb (Analyze_External_Property_In_Decl_Part): Remove + local constant Obj. Add local constant Obj_Id. Reimplement the + check which ensures that the related variable is in fact volatile. + (Analyze_Pragma): Reimplement the analysis of external property pragmas. + * sem_util.adb (Is_Enabled): New routine. + (Variable_Has_Enabled_Property): Reimplement the detection of + an enabled external property. + +2014-07-30 Sergey Rybin + + * gnat_ugn.texi, vms_data.ads: gnatstub: describe generating subunits + for body stubs. + +2014-07-30 Pascal Obry + + * g-forstr.adb, g-forstr.ads: New. + * gnat_rm.texi, impunit.adb Makefile.rtl: Add new unit + GNAT.Formatted_String. + +2014-07-30 Eric Botcazou + + * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): New predicate. + (Expand_Array_Aggregate): Also enable in-place expansion for + code generated by the compiler. For an object declaration, + set the kind of the object in addition to its type. If an + in-place assignment is to be generated and it can be directly + done by the back-end, do not expand the aggregate. + * fe.h (Is_Others_Aggregate): Declare. + * gcc-interface/trans.c + (gnat_to_gnu) : Add support for an + aggregate with a single Others choice on the RHS by means of + __builtin_memset. Tidy up. + +2014-07-30 Ed Schonberg + + * gnat_rm.texi: minor reformatting. + +2014-07-30 Yannick Moy + + * sem_ch6.adb (Analyze_Subprogram_Helper_Body): Remove body to inline + in SPARK_Mode Off. + +2014-07-30 Robert Dewar + + * gnat_rm.texi: Document additional implementation-defined use + of Constrained. + +2014-07-30 Robert Dewar + + * prj-proc.adb, prj-strt.adb: Update comments. + +2014-07-30 Gary Dismukes + + * sinfo.ads, einfo.ads, checks.ads: Minor typo fix and reformatting. + +2014-07-30 Vincent Celier + + * prj-proc.adb (Imported_Or_Extended_Project_From): New Boolean + parameter No_Extending, defaulted to False. When No_Extending + is True, do not look for an extending project. + (Expression): For a variable reference that is not for the current + project, get its Id calling Imported_Or_Extended_Project_From + with No_Extending set to True. + * prj-strt.adb (Parse_Variable_Reference): If a referenced + variable is not found in the current project, check if it is + defined in one of the projects it extends. + +2014-07-30 Robert Dewar + + * sem_util.adb (Predicate_Tests_On_Arguments): Omit tests for + some additional cases of internally generated routines. + +2014-07-30 Ed Schonberg + + * sem_ch10.adb (Analyze_Proper_Body): When compiling for ASIS, + if the compilation unit is a subunit, extend optional processing + to all subunits of the current one. This allows gnatstub to + supress generation of spurious bodies. + +2014-07-30 Hristian Kirtchev + + * a-cbmutr.adb (Insert_Child): Use local variable First to keep + track of the initial element's index within the tree. + +2014-07-29 Hristian Kirtchev + + * a-cbmutr.adb (Allocate_Node): Remove the two parameter version. + (Insert_Child): Add local variable First. Capture the index of the + first node being created to ensure correct cursor construction + later on. Use the three parameter version of Allocate_Node + when creating multiple children as this method allows aspect + Default_Value to take effect (if applicable). + +2014-07-29 Eric Botcazou + + * exp_aggr.adb (Safe_Slice_Assignment): Remove. + (Expand_Array_Aggregate): For a safe slice assignment, just set + the target and use the common code path. + +2014-07-29 Robert Dewar + + * sem_util.adb, sem_util.ads, sem_res.adb, exp_ch6.adb: Invert + predicate No_Predicate_Test_On_Arguments, new name is + Predicate_Tests_On_Arguments (with the opposite sense). + +2014-07-29 Hristian Kirtchev + + * sem_attr.adb (Resolve_Attribute): Clean up the code for + attribute 'Access. Do not generate an elaboration flag for a + stand alone expression function. The expression of an expression + function is now frozen when the expression function appears as + the prefix of attribute 'Access. + * sem_ch6.adb (Analyze_Expression_Function): Remove local + variable New_Decl and update all references to it after the + rewriting has taken place. Establish the linkages between the + generated spec and body. + +2014-07-29 Robert Dewar + + * sem_prag.adb (ip, rv): Prevent from being optimized away. + * gnatls.adb (gnatls): Set E_Fatal exit status if ali file not found. + * s-imgllb.adb, s-imgllw.adb, s-imgwiu.adb, s-imgbiu.adb: Minor + reformatting. + +2014-07-29 Vincent Celier + + * prj-pp.adb: Minor comment update. + * frontend.adb: If a target dependency info file has been read + through switch -gnateT= add it to the dependencies of the source + being compiled. + +2014-07-29 Robert Dewar + + * sem_ch3.adb, prj.adb: Minor reformatting. + +2014-07-29 Vincent Celier + + * prj-pp.adb (Pretty_Print.Output_Project_File): New + procedure to output project file names between quotes without + concatenation, even if the line is too long. + (Pretty_Print): Use Output_Project_File for project being extended and + project imported. + +2014-07-29 Vincent Celier + + * gnat_ugn.texi: Document that configuration pragmas files are + added to the dependencies, unless they contain only pragmas + Source_File_Name_Project. + +2014-07-29 Robert Dewar + + * frontend.adb: Minor reformatting. + +2014-07-29 Robert Dewar + + * exp_ch6.adb (Add_Call_By_Copy_Code): Minor reformatting + (Expand_Actuals): Make sure predicate checks are properly applied + for the case of OUT or IN OUT parameters. + * sem_res.adb: Minor reformatting (Resolve_Actuals): Skip + predicate tests on arguments for Finalize + * sem_util.adb (No_Predicate_Test_On_Arguments): Returns True + if predicate tests on subprogram arguments should be skipped. + * sem_util.ads (No_Predicate_Test_On_Arguments): New function + +2014-07-29 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): If there is an address + clause for the object and the expression is an aggregate, defer + resolution and expansion of the aggregate until the freeze point + of the entity. + * sem_aggr.adb (Resolve_Aggregate): An others_clause is legal if + the parent node is an N_Reference generated during expansion. + +2014-07-29 Vincent Celier + + * prj.adb (Add_To_Buffer): Effectively double the size of the buffer. + +2014-07-29 Robert Dewar + + * frontend.adb, inline.adb, sem_util.adb, sem_res.adb, + prepcomp.ads: Minor reformatting and code clean up. + * exp_ch6.adb (Expand_Actuals): Generate predicate test + unconditionally for case of OUT or IN OUT actual (before this + was generated only for certain subcases, which is wrong, the + test is always needed). + +2014-07-29 Ed Schonberg + + * sem_ch3.adb: Move Has_Defaulted_Discriminants to sem_util. + * sem_ch4.adb (Analyze_Allocator): Defer resolution of expression + until context type is available. + * sem_res.adb (Resolve_Allocator): In the case of a qualified + expression, complete resolution of expression. + (Check_Aliased_Parameter): New procedure within Resolve_Actuals, + to apply Ada2012 checks on aliased formals, as well as + accesibility checks when the context of the call is an allocator + or a qualified expression. + * sem_util.ads, sem_util.adb (Has_Defaulted_Discriminants): + Moved here from sem_ch3. + (Object_Access_Level): Handle properly aliased formals and + aggregates. + * exp_ch6.adb (Expand_Call): Remove check on aliased parameters, + now properly performed in sem_res (Resolve_Actuals, + Check_Aliased_Parameter). + +2014-07-29 Yannick Moy + + * debug.adb Enable GNATprove inlining under debug flag -gnatdQ for now. + * inline.ads, inline.adb (Can_Be_Inlined_In_GNATprove_Mode): New + function to decide when a subprogram can be inlined in GNATprove mode. + (Check_And_Build_Body_To_Inline): Include GNATprove_Mode as a + condition for possible inlining. + * sem_ch10.adb (Analyze_Compilation_Unit): Remove special case + for Inline_Always in GNATprove mode. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Build inlined + body for subprograms in GNATprove mode, under debug flag -gnatdQ. + * sem_prag.adb Minor change in comments. + * sem_res.adb (Resolve_Call): Only perform GNATprove inlining + inside subprograms marked as SPARK_Mode On. + * sinfo.ads: Minor typo fix. + +2014-07-29 Vincent Celier + + * frontend.adb: Add dependency on gnat.adc when taken into account + and on non-temporary configuration pragmas files specified in + switches -gnatec. + * prepcomp.ads, prepcomp.adb (Add_Dependency): New procedure to add + dependencies on configuration pragmas files. + +2014-07-29 Pat Rogers + + * gnat_ugn.texi: Minor clarification to the explanation for the + GNATtest -v switch. + +2014-07-29 Robert Dewar + + * types.ads (Mechanism_Type): Change range back to -18 .. Int'Last with + documentation that explains the need for this extended range + (use by C_Pass_By_Copy). + +2014-07-29 Robert Dewar + + * gnat_rm.texi, sem_prag.adb: Minor reformatting. + +2014-07-29 Sergey Rybin + + * gnat_ugn.texi: gnatmetric: clarify documentation for cyclomatic + complexity metrics. + +2014-07-29 Thomas Quinot + + PR ada/60652 + * s-oscons-tmplt.c: For Linux, define _BSD_SOURCE in order for + CRTSCTS to be visible. + +2014-07-29 Bob Duff + + * g-trasym.adb, g-trasym.ads: Code cleanup. + +2014-07-29 Doug Rupp + + * sigtramp-vxworks.c: Minor reformatting. + +2014-07-29 Ed Schonberg + + * gnat_rm.texi: No doc needed for Ada2012 aspect + Implicit_dereference. + +2014-07-29 Robert Dewar + + * sem_attr.adb (Attribute_12): New array + (Analyze_Attribute): Check impl-defined Ada 2012 attributes. + (Check_Ada_2012_Attribute): Removed. + +2014-07-29 Doug Rupp + + * init.c (vxworks6): Call sigtramp for RTP (as well as DKM) for ARM, + PPC, and e500. + * sigtramp-vxworks.c: New file. + * sigtramp-armvxw.c, sigtramp-ppcvxw.c: removed files. + +2014-07-29 Ed Schonberg + + * lib-xref.adb (Output_Refs, Check_Type_Reference): For a + derived array type, add information about component type, which + was previously missing in ali file. + * gnat_rm.texi: Add documentation for Atomic_Always_Lock_Free. + +2014-07-29 Thomas Quinot + + * sem_ch3.adb (Constrain_Corresponding_Record): For the case + of the subtype created for a record component, do not mark + the subtype as frozen. For one thing, this is anomalous (in + particular, the base type might not itself be frozen yet); + furthermore, proper freezing of the subtype must happen in any + case. So, we just mark the subtype as requiring delayed freezing + (and we'll actually freeze it when generating the init_proc of + the enclosing record). + Also change the name of the constrained record subtype (append a + 'C' so that it is clearly different from the unconstrained record + type, "related_idV") to make debugging easier. + (Process_Full_View): When creating a full subtype for a pending + private subtype, re-establish the scope of the private subtype + so that we get proper visibility on outer discriminants. + * exp_ch3.adb (Build_Init_Statements): Freeze any component + subtype that is not frozen yet. + +2014-07-29 Vincent Celier + + * prj-proc.adb (Recursive_Process): Always initialize the + environment when the project is an aggregate project, even when + it is not the root tree. +2014-07-29 Robert Dewar + + * exp_ch5.adb, exp_ch9.adb: Minor comment additions. + * gnat_rm.texi: Complete list of implementation aspects. + * aspects.ads: Minor comment clarification. + +2014-07-29 Ed Schonberg + + * exp_ch5.adb (Expand_N_Assignment_Statement): If the target type + is a null-excluding access type, do not generate a constraint + check if Suppress_Assignment_Checks is set on assignment node. + * exp_ch9.adb (Build_Simple_Entry_Call): If actual is an out + parameter of a null-excluding access type, there is access check + on entry, so set Suppress_Assignment_Checks on generated statement + that assigns actual to parameter block. + * sinfo.ads: Document additional use of Suppress_Assignment_Checks. + +2014-07-29 Robert Dewar + + * gnat_rm.texi: Change theta to @ in documentation of aspect + Dimension_System. + +2014-07-29 Robert Dewar + + * sem_attr.adb (Uneval_Old_Msg): Flags Uneval_Old_Accept/Warn + are now on pragma. + * sem_ch13.adb (Analyze_Aspect_Specifications): Remove setting + of Uneval_Old_* + * sem_prag.adb (Analyze_Pragma): Set Uneval_Old_* flags + * sinfo.ads, sinfo.adb: Move Uneval_Old_Accept/Warn to N_Pragma node. + +2014-07-29 Javier Miranda + + * types.ads Update documentation on how to add new reason codes + for exceptions. + (RT_Exception_Code): Keep values ordered by their + reason code. Required by the .NET backend. + (RT_CE_Exceptions): Subtype declaration removed. + (RT_PE_Exceptions): Subtype declaration removed. + (RT_SE_Exceptions): Subtype declaration removed. + (Kind): New mapping table of RT_Exception_Codes. + * exp_ch11.adb (Get_RT_Exception_Entity): Updated to use the + new mapping table. + * tbuild.adb (Make_Raise_Storage_Error): Updated to use the new + mapping table. (Make_Raise_Program_Error): Updated to use the + new mapping table. + (Make_Raise_Storage_Error): Updated to use the new mapping table. + * a-except.adb Keep Rcheck_CE_xxx entities ordered according to + their reason code. + +2014-07-29 Thomas Quinot + + * gnat_rm.texi: Document internal attributes used for PolyORB/DSA + distributed stubs generation. + * exp_ch3.adb: Minor reformatting. + +2014-07-29 Yannick Moy + + * sinfo.ads: Document constraint between frontend and GNATprove. + +2014-07-29 Robert Dewar + + * a-except.adb: Minor comment clarification. + +2014-07-29 Robert Dewar + + * gnat_rm.texi: Complete list of implementation attributes. + * snames.ads-tmpl: Clean up list of impl-defined attributes. + +2014-07-29 Hristian Kirtchev + + * freeze.adb (Freeze_Record_Type): Perform various + volatility-related checks. + +2014-07-29 Robert Dewar + + * sem_ch3.adb, sem_eval.adb: Minor reformatting. + +2014-07-29 Ed Schonberg + + * sem_attr.adb: sem_attr.adb (Access_Attribute): Handle properly + the case where the attribute reference appears in a nested scope + from that of the subprogram prefix. + * sem_attr.adb: Minor reformatting. + +2014-07-29 Robert Dewar + + * gnat_ugn.texi: Clarify documentation of Initialize_Scalar + initialization options. + +2014-07-29 Robert Dewar + + * sinfo.ads: Minor comment addition. + +2014-07-29 Bob Duff + + * sem_eval.adb, sem_ch13.adb: Minor reformatting. + +2014-07-29 Doug Rupp + + * init.c: Complete previous change. + +2014-07-29 Robert Dewar + + * exp_ch4.adb (Expand_N_If_Expression): Deal with unconstrained + array case. + +2014-07-29 Ed Schonberg + + * sem_attr.adb (Access_Attribute): If the prefix is a subprogram + and the completion will appear in the same declarative part, + create elaboration flag. + * exp_util.adb (Set_Elaboration_Flag): If the subprogram body + is a completion of a declaration in the same declarative part, + and the subprogram has had its address taken, add elaboration + check inside the subprogram body, to detect elaboration errors + that may occur through indirect calls. + +2014-07-29 Doug Rupp + + * sigtramp-armvxw.c: Enhance to handle RTP trampolining. + * init.c: Remove guard on sigtramp for ARM VxWorks RTP. + +2014-07-29 Vincent Celier + + * switch-c.adb (Scan_Front_End_Switches): Do not fail when two + runtime directorie specified with two switches --RTS= designate + the same directory, even when there are no literarily the same. + +2014-07-29 Robert Dewar + + * gnat_ugn.texi: Minor documentation clarification. + * switch-c.adb: Minor reformatting. + +2014-07-29 Robert Dewar + + * sem_prag.adb (Analyze_Pragma, case Allow_Integer_Address): + Fix incorrect RTE call which caused bomb if pragma was in + configuration pragma file. + +2014-07-29 Jerome Lambourg + + * expect.c (__gnat_expect_poll): Fix typo in previous change. + * g-expect.adb: Update comments. + +2014-07-29 Arnaud Charlet + + * s-parame-hpux.ads, s-parame-vms-ia64.ads, s-parame.ads + (Default_Attribute_Count): Bump to 16 on native platforms. + +2014-07-29 Ed Schonberg + + * sem_res.adb: Add guard to front-end inlining for SPARK. + +2014-07-29 Robert Dewar + + * sem_ch10.adb, debug.adb, sem_prag.adb, sem_res.adb, sem_ch6.adb: + Minor reformatting. + +2014-07-29 Ed Schonberg + + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Build body to + inline in GNATprove mode when subprogran is marked Inline_Always. + * sem_res.adb (Resolve_Call): Expand call in place in GNATProve + mode if body to inline is available. + * sem_prag.adb (Analyze_Pragma, case Inline_Always): Make pragma + effective in GNATprove mode. + * sem_ch10.adb (Analyze_Compilation_Unit): Call + Check_Package_Body_For_Inlining in GNATprove mode, so that body + containing subprograms with Inline_Always can be available before + calls to them. + +2014-07-29 Ed Schonberg + + * inline.ads, inline.adb, sem_ch10.adb: Rename Check_Body_For_Inlining + to Check_Package_Body_For_Inlining, to prevent confusion with other + inlining subprograms. + +2014-07-29 Robert Dewar + + * opt.ads: Minor comment update. + * sem_attr.adb (Uneval_Old_Msg): Deal with case of aspect, where + we want setting of Uneval_Old at time of encountering the aspect. + * sem_ch13.adb (Analyze_Aspect_Specifications): Capture setting + of Opt.Uneval_Old. + * sinfo.adb (Uneval_Old_Accept): New function (Uneval_Old_Warn): + New function (Set_Uneval_Old_Accept): New procedure. + (Set_Uneval_Old_Warn): New procedure. + * sinfo.ads: Uneval_Old_Accept: New flag Uneval_Old_Warn: New flag. + +2014-07-29 Robert Dewar + + * sinfo.ads, inline.adb, inline.ads, sem_ch6.adb: Minor reformatting. + * snames.ads-tmpl: Minor reformatting. + * xsnamest.adb (XSnamesT): Remove special casing of Name_Error + to give . Not clear why this was there, but the compiler + sources do not reference Name_Error, and this interfered with + the circuits for pragma Unevaluated_Use_Of_Old. + +2014-07-29 Hristian Kirtchev + + * sem_prag.adb (Process_Atomic_Shared_Volatile): Allow volatile + types in SPARK 2014 (again). + * sem_res.adb (Is_OK_Volatile_Context): New routine. + (Resolve_Entity_Name): Ensure that a volatile object with + enabled properties Async_Writers or Effectire_Reads appears in + a non-interfering context. + +2014-07-29 Ed Schonberg + + * sem_ch6.adb: Move Build_Body_To_Inline, + Check_And_Buid_Body_To_Inline, and Cannot_Inline to package Inline. + * exp_ch6.adb: Mode Expand_Inlined_Body to package Inline. + * inline.ads, inline.adb: Package now contains subprograms that + implement front-end inlining. No functional changes, no test + needed. + +2014-07-29 Robert Dewar + + * exp_dbug.adb, g-expect.adb, sem_elab.adb: Minor typo fix. + +2014-07-29 Ed Schonberg + + * sem_ch6.adb (Analyze_Return_Type): Reject a return type that + is a limited view when the context is a package body, because + there is no subsequent place at which the non-limited view may + become visible. + (Process_Formals): Ditto. + * sinfo.ads, par-ch3.adb: Minor reformatting. + +2014-07-29 Jerome Lambourg + + * expect.c (__gnat_expect_poll): New parameter dead_process + used to return the dead process among the array of file + descriptors. The Windows, VMS and HPUX implementations now + properly report the dead process via this parameter. Other unixes + don't need it. + * g-expect.adb (Poll): Adapt to the C profile. + (Expect_Internal): Use the new parameter to properly close the + File Descriptor. This then can be properly reported by the + function First_Dead_Process as is expected. + +2014-07-29 Robert Dewar + + * gnat_ugn.texi: Minor clarification of -gnatQ switch. + +2014-07-29 Robert Dewar + + * einfo.adb (Derived_Type_Link): New function + (Set_Derived_Type_Link): New procedure. + (Write_Field31_Name): Output Derived_Type_Link. + * einfo.ads: New field Derived_Type_Link. + * exp_ch6.adb (Expand_Call): Warn if change of representation + needed on call. + * sem_ch13.adb: Minor addition of ??? comment. + (Rep_Item_Too_Late): Warn on case that is legal but could cause an + expensive implicit conversion. + * sem_ch3.adb (Build_Derived_Type): Set Derived_Type_Link if needed. + +2014-07-29 Hristian Kirtchev + + * exp_ch3.adb (Build_Init_Procedure): Renamed Local_DF_Id + to DF_Id. Add new local variable DF_Call. Do not perform any + elaboration-related checks on the call to the partial finalization + routine within an init proc to avoid generating bogus elaboration + warnings on expansion-related code. + * sem_elab.adb (Check_A_Call): Move constant Access_Case to + the top level of the routine. Ensure that Output_Calls takes + into account flags -gnatel and -gnatwl when emitting warnings + or info messages. + (Check_Internal_Call_Continue): Update the call to Output_Calls. + (Elab_Warning): Moved to the top level of routine Check_A_Call. + (Emit): New routines. + (Output_Calls): Add new formal parameter Check_Elab_Flag along with a + comment on usage. Output all warnings or info messages only when the + caller context demands it and the proper elaboration flag is set. + +2014-07-29 Yannick Moy + + * sem_attr.adb (Analyze_Attribute/Attribute_Old): + Check rule about Old appearing in potentially unevaluated + expression everywhere, not only in Post. + +2014-07-29 Arnaud Charlet + + * sem_prag.adb: Update comment. + * a-except.adb, a-except-2005.adb: Minor editing. + +2014-07-29 Pierre-Marie Derodat + + * exp_dbug.adb (Debug_Renaming_Declaration): + Do not create renaming entities for renamings of non-packed + objects and for exceptions. + +2014-07-29 Robert Dewar + + * sem_ch3.adb, sinfo.ads, types.ads, sem_prag.adb, a-except-2005.adb, + sem_ch6.adb, par-ch3.adb: Minor reformatting. + +2014-07-29 Ed Schonberg + + * sem_ch6.adb (Check_Return_Subtype_Indication): Reject a return + subtype indication in an extended return statement when the + return value is an ancestor of the return type of the function, + and that return type is a null record extension. + +2014-07-29 Thomas Quinot + + * sem_ch13.adb (Rep_Item_Too_Late): Specialize/clarify error + message produced for the case of a type-related representation + item that is made illegal by 13.10(1). + * gnat_rm.texi (Scalar_Storage_Order): Minor change in + documentation. + +2014-07-29 Robert Dewar + + * gnat_ugn.texi: Add section on Wide_Wide_Character encodings. + * erroutc.adb (Output_Error_Msgs): Take wide characters into + account in computing position of error flags. + * sinput.adb (Get_Column_Number): Take wide characters into + account. + +2014-07-29 Ed Schonberg + + * par-ch3.adb (P_Access_Type_Definition): The subtype indication + in an access type definition can carry a null_exclusion indicator. + * sem_ch3.adb (Access_Type_Declaration): If the subtype indication + carries a null_exclusion indicator, verify that the subtype + indication denotes an access type, and create a null-excluding + subtype for it. + * sinfo.ads, sinfo.adb: New attribute Null_Excluding_Subtype, + defined on N_Access_To_Object_Definition to indicate that the + subtype indication carries a null_exclusion indicator. + +2014-07-29 Hristian Kirtchev + + * exp_ch6.adb (Add_Extra_Actual): Do not construct + the extra actual by name, generate a reference instead. + +2014-07-29 Arnaud Charlet + + * sem_prag.adb (Analyze_Pragma): Do not crash analyzing + Allow_Integer_Address if already set. + * a-except-2005.adb (Rcheck_PE_Stream_Operation_Not_Allowed): + Fix order, for consistency with Rmsg_xx declarations. + +2014-07-29 Ed Schonberg + + * sem_ch4.adb (Complete_Object_Operation): If the type of the + candidate subprogram is a limited view, use non-limited view + when available. + +2014-07-29 Robert Dewar + + * sem_ch13.adb: Minor change in RM reference. + * sem_mech.ads: Minor reformatting. + * einfo.ads: Minor comment fix. + * types.ads: Minor correction to range given for Mechanism_Type. + * exp_ch6.adb (Add_Invariant_And_Predicate_Checks): Do not + check predicate on way out for OUT or IN OUT parameters. + * par-ch3.adb (P_Constraint_Opt): Handle missing RANGE keyword + better (P_Range_Constraint): Corresponding fix. + * checks.ads: Minor comment clarification. + +2014-07-29 Gary Dismukes + + * sem_ch8.adb (Analyze_Object_Renaming): Set the Is_Volatile + and Treat_As_Volatile flags based on whether the renamed object + is a volatile object. + +2014-07-29 Olivier Hainque + + * g-debpoo.adb + (Default_Alignment): Rename as Storage_Alignment. This is not + a "default" that can be overriden. Augment comment to clarify + intent and document why we need to manage alignment padding. + (Header_Offset): Set to Header'Object_Size instead of 'Size + rounded up to Storage_Alignment. Storage_Alignment on the + allocation header is not required by our internals so was + overkill. 'Object_Size is enough to ensure proper alignment + of the header address when substracted from a storage address + aligned on Storage_Alignment. + (Minimum_Allocation): Rename as Extra_Allocation, conveying that + this is always added on top of the incoming allocation requests. + (Align): New function, to perform alignment rounding operations. + (Allocate): Add comments on the Storage_Address computation + scheme and adjust so that the alignment padding applies to that + (Storage_Address) only. + +2014-07-29 Robert Dewar + + * exp_ch3.adb (Default_Initialize_Object): Remove incorrect + pragma Unreferenced. + * cstand.adb (Create_Standard): Use E_Array_Type for standard + string types. Make sure index of Any_String/Any_Array is in a list. + * errout.adb: Minor reformatting. + +2014-07-29 Robert Dewar + + * gnat_ugn.texi: Clean up and correct documentation of warnings. + * usage.adb: Minor corrections to make sure warnings are properly + documented. + * warnsw.adb (Set_Warning_Switch): Remove redundant return statement. + (WA_Warnings): Add Warn_On_Suspicious_Modulus_Value. + +2014-07-29 Ed Schonberg + + * exp_ch3.adb (Expand_N_Object_Declaration): The dummy block + created to match internal sequence numbers between compilations + with/without abort must have its type properly set. + +2014-07-29 Robert Dewar + + * ali.adb (Initialize_ALI): Initialize SSO_Default_Specified + (Scan_ALI): Set SSO_Default in ALIs_Record (Scan_ALI): Set + SSO_Default_Specified. + * ali.ads (ALIs_Record): Add field SSO_Default + (SSO_Default_Specified): New global switch. + * bcheck.adb (Check_Consistent_SSO_Default): New procedure + (Check_Configuration_Consistency): Call this procedure + * einfo.adb (SSO_Set_High_By_Default): New + function (SSO_Set_Low_By_Default): New function + (Set_SSO_Set_High_By_Default): New procedure + (Set_SSO_Set_Low_By_Default): New procedure (Write_Entity_Flags): + List new flags + * einfo.ads (SSO_Set_Low_By_Default): New flag + (SSO_Set_High_By_Default): New flag + * freeze.adb (Set_SSO_From_Default): New procedure + (Freeze_Array_Type): Call Set_SSO_From_Default + (Freeze_Record_Type): Call Set_SSO_From_Default + * gnat_rm.texi: Document pragma Default_Scalar_Storage_Order + * lib-writ.adb (Write_ALI): Set OL/OH in P line as needed + * lib-writ.ads: Add OL/OH parameters to P line + * opt.adb: Set Default_SSO, Default_SSO_Config as appropriate + * opt.ads (Default_SSO): New global switch (Default_SSO_Config): + New global switch + * repinfo.adb (List_Scalar_Storage_Order): List SSO when it is + set by default using pragma Default_Scalar_Storage_Order. + * sem.ads (Scope_Stack_Entry): Add component Save_Default_SSO + * sem_ch13.adb (Inherit_Delayed_Rep_Aspects): + Clear SSO defaults when explicit SSO is inherited. + (Analyze_Attribute_Definition_Clause): Clear SSO defaults when + explicit SSO is specified. + (Inherit_Aspects_At_Freeze_Point): + Clear SSO default when inheriting SSO. + * sem_ch3.adb (Set_Default_SSO): New procedure + (Analyze_Private_Extension_Declaration): Set defualt SSO + (Array_Type_Declaration): ditto (Build_Derived_Array_Type): ditto + (Build_Derived_Private_Type): ditto (Build_Derived_Record_Type): + ditto (Build_Derived_Type): ditto (Make_Class_Wide_Type): ditto + (Record_Type_Declaration): ditto + * sem_ch8.adb (Pop_Scope): Restore Default_SSO (Push_Scope): + Save Default_SSO + * sem_prag.adb (Analyze_Pragma, case + Default_Scalar_Storage_Order): Set Default_SSO + +2014-07-29 Ed Schonberg + + * sem_ch6.adb (Valid_Operator_Definition): Verify that + all parameter have mode IN. This check must be done here for + subprogram instantiations that have operator names, because their + analysis does not follow the same path as that for subprogram + declarations. + +2014-07-29 Robert Dewar + + * freeze.adb (Freeze_Entity, Concurrent_Type case): Add a guard + to make sure that the Etype of a component of the corresponding + record type is present before trying to freeze it. + * sem_ch5.adb: Minor reformatting. + +2014-07-29 Robert Dewar + + * exp_attr.adb, types.ads, types.h, exp_ch11.adb, a-except.adb, + a-except-2005.adb: Add new reason code PE_Stream_Operation_Not_Allowed, + and then use it when a stream operation is used from a library generic + when the restriction (No_Streams) is active. + +2014-07-29 Thomas Quinot + + * projects.texi: Fix minor typo. + +2014-07-29 Yannick Moy + + * sem_attr.adb (Analyze_Attribute): Fix generation of warning. + +2014-07-29 Arnaud Charlet + + * sem_ch5.adb (Check_Unreachable_Code): Do not remove code in + CodePeer mode. + +2014-07-29 Hristian Kirtchev + + * exp_ch7.adb (Find_Last_Init): Add local variable + Deep_Init_Found. Check the statement immediately following the + declaration if [Deep_]Initialization was not found. + +2014-07-29 Hristian Kirtchev + + * exp_util.adb (Is_Aliased): It appears that + 'reference-d and renamed objects still play some role in Boolean + expression with actions and cannot be finalized immediately. + +2014-07-29 Ed Schonberg + + * exp_dbug.adb (Qualify_Needed): For debugging purposes, + Loop names are not part of the full qualification of entity names. + +2014-07-29 Robert Dewar + + * einfo.adb (Has_Protected): Test base type. + * sem_ch4.adb (Analyze_Allocator): Reorganize code to make sure + that we always properly check No_Protected_Type_Allocators. + +2014-07-29 Ed Schonberg + + * sem_util.ads, sem_util.adb (Defining_Entity): Now applies to + loop declarations as well. + * exp_ch5.adb (Expand_Loop_Statement): Apply Qualify_Entity_Names + to an iterator loop, because it may contain local renaming + declarations that require debugging information. + +2014-07-29 Robert Dewar + + * sem_util.ads, exp_util.adb, sem_attr.adb: Minor reformatting. + +2014-07-29 Robert Dewar + + * einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function + (Set_Static_Real_Or_String_Predicate): New procedure + * sem_ch13.adb (Build_Predicate_Functions): Accomodate static + string predicates (Is_Predicate_Static): Handle static string + predicates. + * sem_eval.adb (Real_Or_String_Static_Predicate_Matches): + New procedure (Check_Expression_Against_Static_Predicate): + Deal with static string predicates, now fully implemented + (Eval_Relational_Op): Allow string equality/inequality as static + if not comes from source. + +2014-07-29 Robert Dewar + + * sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb, + einfo.ads, sem_util.adb, sem_attr.adb, sem_case.adb, sem_eval.adb, + sem_eval.ads, sem_ch13.adb: General cleanup of static predicate + handling. Change name of Discrete_Predicate to + Discrete_Static_Predicate, and replace testing of the presence of this + field by testing the flag Has_Static_Expression. + +2014-07-29 Robert Dewar + + * gnat_rm.texi: Document pragma Unevaluated_Use_Of_Old. + * opt.adb: Handle Uneval_Old. + * opt.ads (Uneval_Old, Uneval_Old_Config): New variables. + * par-prag.adb: Add dummy entry for pragma Unevaluated_Use_Of_Old. + * sem.ads (Save_Uneval_Old): New field in Scope_Stack_Entry. + * sem_attr.adb (Uneval_Old_Msg): New procedure. + * sem_ch8.adb (Push_Scope): Save Uneval_Old. + (Pop_Scope): Restore Uneval_Old. + * sem_prag.adb (Analyze_Pragma, case Unevaluated_Use_Of_Old): + Implemented. + * snames.ads-tmpl: Add entries for pragma Unevaluated_Use_Of_Old + Add entries for Name_Warn, Name_Allow. + +2014-07-29 Robert Dewar + + * sem_aggr.adb (Resolve_Array_Aggregate): Change Is_Static_Range + to Is_OK_Static_Range. + * sem_attr.adb (Eval_Attribute): Make sure we properly flag + static attributes (Eval_Attribute, case Size): Handle size of + zero properly (Eval_Attribute, case Value_Size): Handle size of + zero properly. + * sem_ch13.adb: Minor reformatting. + * sem_ch3.adb (Process_Range_Expr_In_Decl): Change + Is_Static_Range to Is_OK_Static_Range. + * sem_eval.adb (Eval_Case_Expression): Total rewrite, was + wrong in several ways (Is_Static_Range): Moved here from spec + (Is_Static_Subtype): Moved here from spec Change some incorrect + Is_Static_Subtype calls to Is_OK_Static_Subtype. + * sem_eval.ads: Add comments to section on + Is_Static_Expression/Raises_Constraint_Error (Is_OK_Static_Range): + Add clarifying comments (Is_Static_Range): Moved to body + (Is_Statically_Unevaluated): New function. + * sem_util.ads, sem_util.adb (Is_Preelaborable_Expression): Change + Is_Static_Range to Is_OK_Static_Range. + * sinfo.ads: Additional commments for Is_Static_Expression noting + that clients should almost always use Is_OK_Static_Expression + instead. Many other changes throughout front end units to obey + this rule. + * tbuild.ads, tbuild.adb (New_Occurrence_Of): Set Is_Static_Expression + for enumeration literal. + * exp_ch5.adb, sem_intr.adb, sem_ch5.adb, exp_attr.adb, exp_ch9.adb, + lib-writ.adb, sem_ch9.adb, einfo.ads, checks.adb, checks.ads, + sem_prag.adb, sem_ch12.adb, freeze.adb, sem_res.adb, exp_ch4.adb, + exp_ch6.adb, sem_ch4.adb, sem_ch6.adb, exp_aggr.adb, sem_cat.adb: + Replace all occurrences of Is_Static_Expression by + Is_OK_Static_Expression. + +2014-07-29 Hristian Kirtchev + + * exp_ch4.adb (Process_Transient_Object): Remove constant + In_Cond_Expr, use its initialization expression in place. + * exp_ch7.adb (Process_Declarations): There is no need to check + that a transient object being hooked is controlled as it would + not have been hooked in the first place. + * exp_util.adb (Is_Aliased): 'Reference-d or renamed transient + objects are not considered aliased when the related context is + a Boolean expression_with_actions. + (Requires_Cleanup_Actions): There is no need to check that a transient + object being hooked is controlled as it would not have been hooked in + the first place. + +2014-07-29 Robert Dewar + + * errout.adb: Minor reformatting. + +2014-07-29 Hristian Kirtchev + + * exp_ch3.adb (Default_Initialize_Object): Add new variables + Abrt_Blk and Dummy. Generate a dummy temporary when aborts are + not allowed to ensure the symmetrical generation of symbols. + * exp_ch7.adb (Build_Object_Declarations): Remove variables A_Expr + and E_Decl. Add new variables Decl and Dummy. Generate a dummy + temporary when aborts are not allowed to ensure symmertrical + generation of symbols. + * exp_intr.adb (Expand_Unc_Deallocation): Add new variable + Dummy. Generate a dummy temporary when aborts are not allowed + to ensure symmertrical generation of symbols. + +2014-07-29 Ed Schonberg + + * exp_dbug.adb (Debug_Renaming_Declaration): For an object + renaming, indicate that the renamed entity itself needs debug + information. This is necessary if that entity is a temporary, + e.g. part of the expansion of an explicit dereference in an + iterator. + +2014-07-29 Thomas Quinot + + * errout.adb (Set_Error_Posted): When propagating flag to + an enclosing named association, also propagate to the parent + of that node, so that named and positional associations are + treated consistently. + +2014-07-29 Ed Schonberg + + * sem_attr.adb (Resolve_Attribute, case 'Update): Set + Do_Range_Check properly on array component expressions that + have a scalar type. In GNATprove mode, only checks on scalar + components must be marked by the front-end. + +2014-07-29 Ed Schonberg + + * sem_res.adb (Resolve_Type_Conversion): If the type of the + expression is a limited view, use the non-limited view when + available. + +2014-07-29 Hristian Kirtchev + + * exp_ch4.adb (Expand_N_Case_Expression): Mark the generated + case statement as coming from a conditional expression. + (Expand_N_If_Expression): Mark the generated if statement as + coming from a conditional expression. + * exp_ch5.adb (Expand_N_Case_Statement): Do not process controlled + objects found in case statement alternatives when the case + statement is actually a case expression. + (Expand_N_If_Statement): + Do not process controlled objects found in an if statement when + the if statement is actually an if expression. + * sinfo.adb (From_Conditional_Expression): New routine. + (Set_From_Conditional_Expression): New routine. + * sinfo.ads Add new semantic flag From_Conditional_Expression and + update related nodes. + (From_Conditional_Expression): New routine along with pragma Inline. + (Set_From_Conditional_Expression): New routine along with pragma Inline. + +2014-07-29 Hristian Kirtchev + + * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Remove + formal parameter Obj_Id and update the comment on usage. Renamed + Obj_Typ to Func_Typ and update all occurrences. + (Find_Last_Init): Remove formal parameter Decl and update the comment + on usage. + Remove local constants Obj_Id and Obj_Typ. Remove local variables + Init_Typ and Is_Conc. Remove the extraction of the initialization type. + (Find_Last_Init_In_Block): Remove formal parameter + Init_Typ and update the comment on usage. + (Is_Init_Call): Remove formal parameter Init_Typ and update the comment + on usage. Check whether the procedure call is an initialization + procedure of either the object type or the initialization type. + (Is_Init_Proc_Of): New routine. + (Process_Object_Declaration): Obj_Id and Obj_Typ are now global to this + routine. Add new variable Init_Typ. Add circuitry to extract the object + type as well as the initialization type. + +2014-07-29 Robert Dewar + + * sem_case.adb: Minor reformatting. + * sem_aux.ads: Minor reformatting. + +2014-07-29 Ed Schonberg + + * sinfo.adb (Set_Else_Actions, Set_Then_Actions): Set parent + pointer on these fields, even though they are semantic, because + subsequent analysis and expansion of action nades may require + exploring the tree, for example to locate a node to be wrapped + when a function with controlled result is called. + +2014-07-29 Claire Dross + + * sem_aux.adb (Get_Binary_Nkind): Use case on + Name_Id instead of an intermediate string. + (Get_Unary_Nkind): Use case on Name_Id instead of an intermediate + string. + +2014-07-29 Sergey Rybin + + * gnat_ugn.texi (gnatelim, gnatstub, gnatmetric): Add note + about processing sources with preprocessor directives. + +2014-07-24 Martin Liska + + * gcc-interface/trans.c (finalize_nrv): Adjust function call. + * gcc-interface/utils.c (rest_of_subprog_body_compilation): Likewise. + (gnat_write_global_declarations): Likewise. + 2014-07-19 David Wohlferd * gnat_rm.texi: Clean up for makeinfo 5.2. @@ -92,6 +5074,7 @@ * a-witeio.adb (Put): No 16-bit character output when text translation is disabled. * i-cstrea.ads: Code clean up. + 2014-07-18 Robert Dewar * gnat_rm.texi: Document that Wchar_T_Size and Word_Size are diff --git a/main/gcc/ada/Make-generated.in b/main/gcc/ada/Make-generated.in index 412e18b58c0..757eaa85b90 100644 --- a/main/gcc/ada/Make-generated.in +++ b/main/gcc/ada/Make-generated.in @@ -66,48 +66,6 @@ $(ADA_GEN_SUBDIR)/stamp-nmake: $(ADA_GEN_SUBDIR)/sinfo.ads $(ADA_GEN_SUBDIR)/nma $(MOVE_IF_CHANGE) $(ADA_GEN_SUBDIR)/bldtools/nmake/nmake.adb $(ADA_GEN_SUBDIR)/nmake.adb touch $(ADA_GEN_SUBDIR)/stamp-nmake -# GCC_FOR_TARGET has paths relative to the gcc directory, so we need to adjust -# for running it from $(ADA_GEN_SUBDIR)/bldtools/oscons. - -OSCONS_CC=$(subst ./xgcc,../../../xgcc,$(subst -B./, -B../../../,$(GCC_FOR_TARGET))) - -# The main ada source directory must be on the include path for #include "..." -# because s-oscons-tmplt.c requires adaint.h, gsocket.h, and any file included -# by these headers. However note that we must use -iquote, not -I, so that -# ada/types.h does not conflict with a same-named system header (VxWorks -# has a header). - -OSCONS_SRCDIR=$${_oscons_srcdir} -OSCONS_CPP=$(OSCONS_CC) $(GNATLIBCFLAGS) -E -C \ - -DTARGET=\"$(target)\" -iquote $(OSCONS_SRCDIR) s-oscons-tmplt.c > s-oscons-tmplt.i -OSCONS_EXTRACT=$(OSCONS_CC) -iquote $(OSCONS_SRCDIR) -S s-oscons-tmplt.i - -# Note: if you need to build with a non-GNU compiler, you could adapt the -# following definitions (written for VMS DEC-C) -#OSCONS_CPP=../../../$(DECC) -E /comment=as_is -DNATIVE \ -# -DTARGET='""$(target)""' -I$(OSCONS_SRCDIR) s-oscons-tmplt.c -# -#OSCONS_EXTRACT=../../../$(DECC) -DNATIVE \ -# -DTARGET='""$(target)""' -I$(OSCONS_SRCDIR) s-oscons-tmplt.c ; \ -# ld -o s-oscons-tmplt.exe s-oscons-tmplt.obj; \ -# ./s-oscons-tmplt.exe > s-oscons-tmplt.s - -# Note: the first dependency of s-oscons.ads *must* remain s-oscons-tmplt.c, as -# we use $(tmp-sdefault.adb @@ -137,11 +95,3 @@ $(ADA_GEN_SUBDIR)/stamp-sdefault : $(srcdir)/version.c Makefile $(ECHO) "end Sdefault;" >> tmp-sdefault.adb $(MOVE_IF_CHANGE) tmp-sdefault.adb $(ADA_GEN_SUBDIR)/sdefault.adb touch $(ADA_GEN_SUBDIR)/stamp-sdefault - -$(ADA_GEN_SUBDIR)/gnat.hlp : $(ADA_GEN_SUBDIR)/vms_help.adb $(ADA_GEN_SUBDIR)/vms_cmds.ads $(ADA_GEN_SUBDIR)/gnat.help_in $(ADA_GEN_SUBDIR)/vms_data.ads - -$(MKDIR) $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp - $(RM) $(addprefix $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp/,$(notdir $^)) - $(CP) $^ $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp - (cd $(ADA_GEN_SUBDIR)/bldtools/gnat_hlp; \ - gnatmake -q vms_help; \ - ./vms_help$(build_exeext) gnat.help_in vms_data.ads ../../gnat.hlp) diff --git a/main/gcc/ada/Makefile.rtl b/main/gcc/ada/Makefile.rtl index a40dff5eeea..cfab8cf350a 100644 --- a/main/gcc/ada/Makefile.rtl +++ b/main/gcc/ada/Makefile.rtl @@ -18,7 +18,7 @@ #. # This makefile fragment is included in the ada Makefile (both Unix -# and NT and VMS versions). +# and Windows). # Its purpose is to allow the separate maintainence of the list of # GNATRTL objects, which frequently changes. @@ -44,7 +44,6 @@ GNATRTL_TASKING_OBJS= \ g-signal$(objext) \ g-tastus$(objext) \ g-thread$(objext) \ - s-asthan$(objext) \ s-inmaop$(objext) \ s-interr$(objext) \ s-intman$(objext) \ @@ -99,12 +98,12 @@ GNATRTL_NONTASKING_OBJS= \ a-calend$(objext) \ a-calfor$(objext) \ a-catizo$(objext) \ + a-cbdlli$(objext) \ a-cbhama$(objext) \ a-cbhase$(objext) \ - a-cborse$(objext) \ - a-cbdlli$(objext) \ a-cbmutr$(objext) \ a-cborma$(objext) \ + a-cborse$(objext) \ a-cbprqu$(objext) \ a-cbsyqu$(objext) \ a-cdlili$(objext) \ @@ -121,8 +120,8 @@ GNATRTL_NONTASKING_OBJS= \ a-charac$(objext) \ a-chlat1$(objext) \ a-chlat9$(objext) \ - a-chtgbo$(objext) \ a-chtgbk$(objext) \ + a-chtgbo$(objext) \ a-chtgke$(objext) \ a-chtgop$(objext) \ a-chzla1$(objext) \ @@ -130,10 +129,13 @@ GNATRTL_NONTASKING_OBJS= \ a-cidlli$(objext) \ a-cihama$(objext) \ a-cihase$(objext) \ + a-cimutr$(objext) \ a-ciorma$(objext) \ a-ciormu$(objext) \ a-ciorse$(objext) \ a-clrefi$(objext) \ + a-cobove$(objext) \ + a-cofove$(objext) \ a-cogeso$(objext) \ a-cohama$(objext) \ a-cohase$(objext) \ @@ -143,10 +145,9 @@ GNATRTL_NONTASKING_OBJS= \ a-colien$(objext) \ a-colire$(objext) \ a-comlin$(objext) \ + a-comutr$(objext) \ a-contai$(objext) \ a-convec$(objext) \ - a-cobove$(objext) \ - a-cofove$(objext) \ a-coorma$(objext) \ a-coormu$(objext) \ a-coorse$(objext) \ @@ -156,8 +157,6 @@ GNATRTL_NONTASKING_OBJS= \ a-crbtgk$(objext) \ a-crbtgo$(objext) \ a-crdlli$(objext) \ - a-comutr$(objext) \ - a-cimutr$(objext) \ a-csquin$(objext) \ a-cuprqu$(objext) \ a-cusyqu$(objext) \ @@ -207,12 +206,12 @@ GNATRTL_NONTASKING_OBJS= \ a-nlcoar$(objext) \ a-nlcoty$(objext) \ a-nlelfu$(objext) \ - a-nlrear$(objext) \ a-nllcar$(objext) \ a-nllcef$(objext) \ a-nllcty$(objext) \ a-nllefu$(objext) \ a-nllrar$(objext) \ + a-nlrear$(objext) \ a-nscefu$(objext) \ a-nscoty$(objext) \ a-nselfu$(objext) \ @@ -224,8 +223,8 @@ GNATRTL_NONTASKING_OBJS= \ a-numaux$(objext) \ a-numeri$(objext) \ a-nurear$(objext) \ - a-rbtgbo$(objext) \ a-rbtgbk$(objext) \ + a-rbtgbo$(objext) \ a-rbtgso$(objext) \ a-sbecin$(objext) \ a-sbhcin$(objext) \ @@ -408,9 +407,11 @@ GNATRTL_NONTASKING_OBJS= \ g-excact$(objext) \ g-except$(objext) \ g-exctra$(objext) \ + s-exctra$(objext) \ g-expect$(objext) \ g-exptty$(objext) \ g-flocon$(objext) \ + g-forstr$(objext) \ g-heasor$(objext) \ g-hesora$(objext) \ g-hesorg$(objext) \ @@ -457,6 +458,7 @@ GNATRTL_NONTASKING_OBJS= \ g-timsta$(objext) \ g-traceb$(objext) \ g-trasym$(objext) \ + s-trasym$(objext) \ g-tty$(objext) \ g-u3spch$(objext) \ g-utf_32$(objext) \ @@ -469,7 +471,6 @@ GNATRTL_NONTASKING_OBJS= \ i-cexten$(objext) \ i-cobol$(objext) \ i-cpoint$(objext) \ - i-cpp$(objext) \ i-cstrea$(objext) \ i-cstrin$(objext) \ i-fortra$(objext) \ @@ -511,8 +512,8 @@ GNATRTL_NONTASKING_OBJS= \ s-crc32$(objext) \ s-crtl$(objext) \ s-diflio$(objext) \ - s-dim$(objext) \ s-diinio$(objext) \ + s-dim$(objext) \ s-dimkio$(objext) \ s-dimmks$(objext) \ s-direio$(objext) \ @@ -538,15 +539,10 @@ GNATRTL_NONTASKING_OBJS= \ s-ficobl$(objext) \ s-filatt$(objext) \ s-fileio$(objext) \ - s-filofl$(objext) \ s-finmas$(objext) \ s-finroo$(objext) \ - s-fishfl$(objext) \ s-flocon$(objext) \ s-fore$(objext) \ - s-fvadfl$(objext) \ - s-fvaffl$(objext) \ - s-fvagfl$(objext) \ s-gearop$(objext) \ s-geveop$(objext) \ s-gloloc$(objext) \ @@ -672,7 +668,6 @@ GNATRTL_NONTASKING_OBJS= \ s-traent$(objext) \ s-unstyp$(objext) \ s-utf_32$(objext) \ - s-vaflop$(objext) \ s-valboo$(objext) \ s-valcha$(objext) \ s-valdec$(objext) \ @@ -688,7 +683,6 @@ GNATRTL_NONTASKING_OBJS= \ s-veboop$(objext) \ s-vector$(objext) \ s-vercon$(objext) \ - s-vmexta$(objext) \ s-wchcnv$(objext) \ s-wchcon$(objext) \ s-wchjis$(objext) \ diff --git a/main/gcc/ada/a-calcon.ads b/main/gcc/ada/a-calcon.ads index e478d508806..0fbf4a178aa 100644 --- a/main/gcc/ada/a-calcon.ads +++ b/main/gcc/ada/a-calcon.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +37,10 @@ with Interfaces.C; package Ada.Calendar.Conversions is function To_Ada_Time (Unix_Time : Interfaces.C.long) return Time; - -- Convert a time value represented as number of seconds since the Unix - -- Epoch to a time value relative to an Ada implementation-defined Epoch. - -- The units of the result are 100 nanoseconds on VMS and nanoseconds on - -- all other targets. Raises Time_Error if the result cannot fit into a - -- Time value. + -- Convert a time value represented as number of seconds since the + -- Unix Epoch to a time value relative to an Ada implementation-defined + -- Epoch. The units of the result are nanoseconds on all targets. Raises + -- Time_Error if the result cannot fit into a Time value. function To_Ada_Time (tm_year : Interfaces.C.int; diff --git a/main/gcc/ada/a-calend-vms.adb b/main/gcc/ada/a-calend-vms.adb deleted file mode 100644 index bb878cbfe45..00000000000 --- a/main/gcc/ada/a-calend-vms.adb +++ /dev/null @@ -1,1317 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version - -with Ada.Unchecked_Conversion; - -with System.Aux_DEC; use System.Aux_DEC; -with System.OS_Primitives; use System.OS_Primitives; - -package body Ada.Calendar is - - -------------------------- - -- Implementation Notes -- - -------------------------- - - -- Variables of type Ada.Calendar.Time have suffix _S or _M to denote - -- units of seconds or milis. - - -- Because time is measured in different units and from different origins - -- on various targets, a system independent model is incorporated into - -- Ada.Calendar. The idea behind the design is to encapsulate all target - -- dependent machinery in a single package, thus providing a uniform - -- interface to all existing and potential children. - - -- package Ada.Calendar - -- procedure Split (5 parameters) -------+ - -- | Call from local routine - -- private | - -- package Formatting_Operations | - -- procedure Split (11 parameters) <--+ - -- end Formatting_Operations | - -- end Ada.Calendar | - -- | - -- package Ada.Calendar.Formatting | Call from child routine - -- procedure Split (9 or 10 parameters) -+ - -- end Ada.Calendar.Formatting - - -- The behaviour of the interfacing routines is controlled via various - -- flags. All new Ada 2005 types from children of Ada.Calendar are - -- emulated by a similar type. For instance, type Day_Number is replaced - -- by Integer in various routines. One ramification of this model is that - -- the caller site must perform validity checks on returned results. - -- The end result of this model is the lack of target specific files per - -- child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc). - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Within_Time_Bounds (T : OS_Time); - -- Ensure that a time representation value falls withing the bounds of Ada - -- time. Leap seconds support is taken into account. - - procedure Cumulative_Leap_Seconds - (Start_Date : OS_Time; - End_Date : OS_Time; - Elapsed_Leaps : out Natural; - Next_Leap_Sec : out OS_Time); - -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or - -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec - -- represents the next leap second occurrence on or after End_Date. If - -- there are no leaps seconds after End_Date, End_Of_Time is returned. - -- End_Of_Time can be used as End_Date to count all the leap seconds that - -- have occurred on or after Start_Date. - -- - -- Note: Any sub seconds of Start_Date and End_Date are discarded before - -- the calculations are done. For instance: if 113 seconds is a leap - -- second (it isn't) and 113.5 is input as an End_Date, the leap second - -- at 113 will not be counted in Leaps_Between, but it will be returned - -- as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is - -- a leap second, the comparison should be: - -- - -- End_Date >= Next_Leap_Sec; - -- - -- After_Last_Leap is designed so that this comparison works without - -- having to first check if Next_Leap_Sec is a valid leap second. - - function To_Duration (T : Time) return Duration; - function To_Relative_Time (D : Duration) return Time; - -- It is important to note that duration's fractional part denotes nano - -- seconds while the units of Time are 100 nanoseconds. If a regular - -- Unchecked_Conversion was employed, the resulting values would be off - -- by 100. - - -------------------------- - -- Leap seconds control -- - -------------------------- - - Flag : Integer; - pragma Import (C, Flag, "__gl_leap_seconds_support"); - -- This imported value is used to determine whether the compilation had - -- binder flag "-y" present which enables leap seconds. A value of zero - -- signifies no leap seconds support while a value of one enables the - -- support. - - Leap_Support : constant Boolean := Flag = 1; - -- The above flag controls the usage of leap seconds in all Ada.Calendar - -- routines. - - Leap_Seconds_Count : constant Natural := 25; - - --------------------- - -- Local Constants -- - --------------------- - - -- The range of Ada time expressed as milis since the VMS Epoch - - Ada_Low : constant OS_Time := (10 * 366 + 32 * 365 + 45) * Milis_In_Day; - Ada_High : constant OS_Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day; - - -- Even though the upper bound of time is 2399-12-31 23:59:59.9999999 - -- UTC, it must be increased to include all leap seconds. - - Ada_High_And_Leaps : constant OS_Time := - Ada_High + OS_Time (Leap_Seconds_Count) * Mili; - - -- Two constants used in the calculations of elapsed leap seconds. - -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time - -- is earlier than Ada_Low in time zone +28. - - End_Of_Time : constant OS_Time := Ada_High + OS_Time (3) * Milis_In_Day; - Start_Of_Time : constant OS_Time := Ada_Low - OS_Time (3) * Milis_In_Day; - - -- The following table contains the hard time values of all existing leap - -- seconds. The values are produced by the utility program xleaps.adb. - - Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of OS_Time := - (35855136000000000, - 36014112010000000, - 36329472020000000, - 36644832030000000, - 36960192040000000, - 37276416050000000, - 37591776060000000, - 37907136070000000, - 38222496080000000, - 38695104090000000, - 39010464100000000, - 39325824110000000, - 39957408120000000, - 40747104130000000, - 41378688140000000, - 41694048150000000, - 42166656160000000, - 42482016170000000, - 42797376180000000, - 43271712190000000, - 43744320200000000, - 44218656210000000, - 46427904220000000, - 47374848230000000, - 48478176240000000); - - --------- - -- "+" -- - --------- - - function "+" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Left + To_Relative_Time (Right); - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - function "+" (Left : Duration; Right : Time) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Right + Left; - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Left - To_Relative_Time (Right); - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - function "-" (Left : Time; Right : Time) return Duration is - pragma Unsuppress (Overflow_Check); - - -- The bound of type Duration expressed as time - - Dur_High : constant OS_Time := - OS_Time (To_Relative_Time (Duration'Last)); - Dur_Low : constant OS_Time := - OS_Time (To_Relative_Time (Duration'First)); - - Res_M : OS_Time; - - begin - Res_M := OS_Time (Left) - OS_Time (Right); - - -- Due to the extended range of Ada time, "-" is capable of producing - -- results which may exceed the range of Duration. In order to prevent - -- the generation of bogus values by the Unchecked_Conversion, we apply - -- the following check. - - if Res_M < Dur_Low - or else Res_M >= Dur_High - then - raise Time_Error; - - -- Normal case, result fits - - else - return To_Duration (Time (Res_M)); - end if; - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) < OS_Time (Right); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) <= OS_Time (Right); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) > OS_Time (Right); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) >= OS_Time (Right); - end ">="; - - ------------------------------ - -- Check_Within_Time_Bounds -- - ------------------------------ - - procedure Check_Within_Time_Bounds (T : OS_Time) is - begin - if Leap_Support then - if T < Ada_Low or else T > Ada_High_And_Leaps then - raise Time_Error; - end if; - else - if T < Ada_Low or else T > Ada_High then - raise Time_Error; - end if; - end if; - end Check_Within_Time_Bounds; - - ----------- - -- Clock -- - ----------- - - function Clock return Time is - Elapsed_Leaps : Natural; - Next_Leap_M : OS_Time; - Res_M : constant OS_Time := OS_Clock; - - begin - -- Note that on other targets a soft-link is used to get a different - -- clock depending whether tasking is used or not. On VMS this isn't - -- needed since all clock calls end up using SYS$GETTIM, so call the - -- OS_Primitives version for efficiency. - - -- If the target supports leap seconds, determine the number of leap - -- seconds elapsed until this moment. - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); - - -- The system clock may fall exactly on a leap second - - if Res_M >= Next_Leap_M then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - return Time (Res_M + OS_Time (Elapsed_Leaps) * Mili); - end Clock; - - ----------------------------- - -- Cumulative_Leap_Seconds -- - ----------------------------- - - procedure Cumulative_Leap_Seconds - (Start_Date : OS_Time; - End_Date : OS_Time; - Elapsed_Leaps : out Natural; - Next_Leap_Sec : out OS_Time) - is - End_Index : Positive; - End_T : OS_Time := End_Date; - Start_Index : Positive; - Start_T : OS_Time := Start_Date; - - begin - pragma Assert (Leap_Support and then End_Date >= Start_Date); - - Next_Leap_Sec := End_Of_Time; - - -- Make sure that the end date does not exceed the upper bound - -- of Ada time. - - if End_Date > Ada_High then - End_T := Ada_High; - end if; - - -- Remove the sub seconds from both dates - - Start_T := Start_T - (Start_T mod Mili); - End_T := End_T - (End_T mod Mili); - - -- Some trivial cases: - -- Leap 1 . . . Leap N - -- ---+========+------+############+-------+========+----- - -- Start_T End_T Start_T End_T - - if End_T < Leap_Second_Times (1) then - Elapsed_Leaps := 0; - Next_Leap_Sec := Leap_Second_Times (1); - return; - - elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then - Elapsed_Leaps := 0; - Next_Leap_Sec := End_Of_Time; - return; - end if; - - -- Perform the calculations only if the start date is within the leap - -- second occurrences table. - - if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then - - -- 1 2 N - 1 N - -- +----+----+-- . . . --+-------+---+ - -- | T1 | T2 | | N - 1 | N | - -- +----+----+-- . . . --+-------+---+ - -- ^ ^ - -- | Start_Index | End_Index - -- +-------------------+ - -- Leaps_Between - - -- The idea behind the algorithm is to iterate and find two closest - -- dates which are after Start_T and End_T. Their corresponding - -- index difference denotes the number of leap seconds elapsed. - - Start_Index := 1; - loop - exit when Leap_Second_Times (Start_Index) >= Start_T; - Start_Index := Start_Index + 1; - end loop; - - End_Index := Start_Index; - loop - exit when End_Index > Leap_Seconds_Count - or else Leap_Second_Times (End_Index) >= End_T; - End_Index := End_Index + 1; - end loop; - - if End_Index <= Leap_Seconds_Count then - Next_Leap_Sec := Leap_Second_Times (End_Index); - end if; - - Elapsed_Leaps := End_Index - Start_Index; - - else - Elapsed_Leaps := 0; - end if; - end Cumulative_Leap_Seconds; - - --------- - -- Day -- - --------- - - function Day (Date : Time) return Day_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, M, S); - begin - Split (Date, Y, M, D, S); - return D; - end Day; - - ------------- - -- Is_Leap -- - ------------- - - function Is_Leap (Year : Year_Number) return Boolean is - begin - -- Leap centennial years - - if Year mod 400 = 0 then - return True; - - -- Non-leap centennial years - - elsif Year mod 100 = 0 then - return False; - - -- Regular years - - else - return Year mod 4 = 0; - end if; - end Is_Leap; - - ----------- - -- Month -- - ----------- - - function Month (Date : Time) return Month_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, D, S); - begin - Split (Date, Y, M, D, S); - return M; - end Month; - - ------------- - -- Seconds -- - ------------- - - function Seconds (Date : Time) return Day_Duration is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, M, D); - begin - Split (Date, Y, M, D, S); - return S; - end Seconds; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration) - is - H : Integer; - M : Integer; - Se : Integer; - Ss : Duration; - Le : Boolean; - - begin - -- Use UTC as the local time zone on VMS, the status of flag Use_TZ is - -- irrelevant in this case. - - Formatting_Operations.Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => Le, - Use_TZ => False, - Is_Historic => True, - Time_Zone => 0); - - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Seconds'Valid - then - raise Time_Error; - end if; - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time - is - -- The values in the following constants are irrelevant, they are just - -- placeholders; the choice of constructing a Day_Duration value is - -- controlled by the Use_Day_Secs flag. - - H : constant Integer := 1; - M : constant Integer := 1; - Se : constant Integer := 1; - Ss : constant Duration := 0.1; - - begin - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Seconds'Valid - then - raise Time_Error; - end if; - - -- Use UTC as the local time zone on VMS, the status of flag Use_TZ is - -- irrelevant in this case. - - return - Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => False, - Use_Day_Secs => True, - Use_TZ => False, - Is_Historic => True, - Time_Zone => 0); - end Time_Of; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - function Time_To_Duration is - new Ada.Unchecked_Conversion (Time, Duration); - begin - return Time_To_Duration (T * 100); - end To_Duration; - - ---------------------- - -- To_Relative_Time -- - ---------------------- - - function To_Relative_Time (D : Duration) return Time is - function Duration_To_Time is - new Ada.Unchecked_Conversion (Duration, Time); - begin - return Duration_To_Time (D / 100.0); - end To_Relative_Time; - - ---------- - -- Year -- - ---------- - - function Year (Date : Time) return Year_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (M, D, S); - begin - Split (Date, Y, M, D, S); - return Y; - end Year; - - -- The following packages assume that Time is a Long_Integer, the units - -- are 100 nanoseconds and the starting point in the VMS Epoch. - - --------------------------- - -- Arithmetic_Operations -- - --------------------------- - - package body Arithmetic_Operations is - - --------- - -- Add -- - --------- - - function Add (Date : Time; Days : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Date_M : constant OS_Time := OS_Time (Date); - begin - return Time (Date_M + OS_Time (Days) * Milis_In_Day); - exception - when Constraint_Error => - raise Time_Error; - end Add; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Left : Time; - Right : Time; - Days : out Long_Integer; - Seconds : out Duration; - Leap_Seconds : out Integer) - is - Diff_M : OS_Time; - Diff_S : OS_Time; - Earlier : OS_Time; - Elapsed_Leaps : Natural; - Later : OS_Time; - Negate : Boolean := False; - Next_Leap : OS_Time; - Sub_Seconds : Duration; - - begin - -- This classification is necessary in order to avoid a Time_Error - -- being raised by the arithmetic operators in Ada.Calendar. - - if Left >= Right then - Later := OS_Time (Left); - Earlier := OS_Time (Right); - else - Later := OS_Time (Right); - Earlier := OS_Time (Left); - Negate := True; - end if; - - -- If the target supports leap seconds, process them - - if Leap_Support then - Cumulative_Leap_Seconds - (Earlier, Later, Elapsed_Leaps, Next_Leap); - - if Later >= Next_Leap then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili; - - -- Sub second processing - - Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F; - - -- Convert to seconds. Note that his action eliminates the sub - -- seconds automatically. - - Diff_S := Diff_M / Mili; - - Days := Long_Integer (Diff_S / Secs_In_Day); - Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds; - Leap_Seconds := Integer (Elapsed_Leaps); - - if Negate then - Days := -Days; - Seconds := -Seconds; - - if Leap_Seconds /= 0 then - Leap_Seconds := -Leap_Seconds; - end if; - end if; - end Difference; - - -------------- - -- Subtract -- - -------------- - - function Subtract (Date : Time; Days : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Date_M : constant OS_Time := OS_Time (Date); - begin - return Time (Date_M - OS_Time (Days) * Milis_In_Day); - exception - when Constraint_Error => - raise Time_Error; - end Subtract; - end Arithmetic_Operations; - - --------------------------- - -- Conversion_Operations -- - --------------------------- - - package body Conversion_Operations is - - Epoch_Offset : constant OS_Time := 35067168000000000; - -- The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in - -- 100 nanoseconds. - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time (Unix_Time : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili; - begin - return Time (Unix_Rep + Epoch_Offset); - exception - when Constraint_Error => - raise Time_Error; - end To_Ada_Time; - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time - (tm_year : Integer; - tm_mon : Integer; - tm_day : Integer; - tm_hour : Integer; - tm_min : Integer; - tm_sec : Integer; - tm_isdst : Integer) return Time - is - pragma Unsuppress (Overflow_Check); - - Year_Shift : constant Integer := 1900; - Month_Shift : constant Integer := 1; - - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Second : Integer; - Leap : Boolean; - Result : OS_Time; - - begin - -- Input processing - - Year := Year_Number (Year_Shift + tm_year); - Month := Month_Number (Month_Shift + tm_mon); - Day := Day_Number (tm_day); - - -- Step 1: Validity checks of input values - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else tm_hour not in 0 .. 24 - or else tm_min not in 0 .. 59 - or else tm_sec not in 0 .. 60 - or else tm_isdst not in -1 .. 1 - then - raise Time_Error; - end if; - - -- Step 2: Potential leap second - - if tm_sec = 60 then - Leap := True; - Second := 59; - else - Leap := False; - Second := tm_sec; - end if; - - -- Step 3: Calculate the time value - - Result := - OS_Time - (Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => 0.0, -- Time is given in h:m:s - Hour => tm_hour, - Minute => tm_min, - Second => Second, - Sub_Sec => 0.0, -- No precise sub second given - Leap_Sec => Leap, - Use_Day_Secs => False, -- Time is given in h:m:s - Use_TZ => True, -- Force usage of explicit time zone - Is_Historic => True, - Time_Zone => 0)); -- Place the value in UTC - -- Step 4: Daylight Savings Time - - if tm_isdst = 1 then - Result := Result + OS_Time (3_600) * Mili; - end if; - - return Time (Result); - exception - when Constraint_Error => - raise Time_Error; - end To_Ada_Time; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration - (tv_sec : Long_Integer; - tv_nsec : Long_Integer) return Duration - is - pragma Unsuppress (Overflow_Check); - begin - return Duration (tv_sec) + Duration (tv_nsec) / Mili_F; - end To_Duration; - - ------------------------ - -- To_Struct_Timespec -- - ------------------------ - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Long_Integer; - tv_nsec : out Long_Integer) - is - pragma Unsuppress (Overflow_Check); - Secs : Duration; - Nano_Secs : Duration; - - begin - -- Seconds extraction, avoid potential rounding errors - - Secs := D - 0.5; - tv_sec := Long_Integer (Secs); - - -- 100 Nanoseconds extraction - - Nano_Secs := D - Duration (tv_sec); - tv_nsec := Long_Integer (Nano_Secs * Mili); - end To_Struct_Timespec; - - ------------------ - -- To_Struct_Tm -- - ------------------ - - procedure To_Struct_Tm - (T : Time; - tm_year : out Integer; - tm_mon : out Integer; - tm_day : out Integer; - tm_hour : out Integer; - tm_min : out Integer; - tm_sec : out Integer) - is - pragma Unsuppress (Overflow_Check); - Year : Year_Number; - Month : Month_Number; - Second : Integer; - Day_Secs : Day_Duration; - Sub_Sec : Duration; - Leap_Sec : Boolean; - - begin - -- Step 1: Split the input time - - Formatting_Operations.Split - (Date => T, - Year => Year, - Month => Month, - Day => tm_day, - Day_Secs => Day_Secs, - Hour => tm_hour, - Minute => tm_min, - Second => Second, - Sub_Sec => Sub_Sec, - Leap_Sec => Leap_Sec, - Use_TZ => True, - Is_Historic => False, - Time_Zone => 0); - - -- Step 2: Correct the year and month - - tm_year := Year - 1900; - tm_mon := Month - 1; - - -- Step 3: Handle leap second occurrences - - tm_sec := (if Leap_Sec then 60 else Second); - end To_Struct_Tm; - - ------------------ - -- To_Unix_Time -- - ------------------ - - function To_Unix_Time (Ada_Time : Time) return Long_Integer is - pragma Unsuppress (Overflow_Check); - Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time); - begin - return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili); - exception - when Constraint_Error => - raise Time_Error; - end To_Unix_Time; - end Conversion_Operations; - - --------------------------- - -- Formatting_Operations -- - --------------------------- - - package body Formatting_Operations is - - ----------------- - -- Day_Of_Week -- - ----------------- - - function Day_Of_Week (Date : Time) return Integer is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - - Day_Count : Long_Integer; - Midday_Date_S : Time; - - begin - Split (Date, Y, M, D, S); - - -- Build a time value in the middle of the same day and convert the - -- time value to seconds. - - Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili; - - -- Count the number of days since the start of VMS time. 1858-11-17 - -- was a Wednesday. - - Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2; - - return Integer (Day_Count mod 7); - end Day_Of_Week; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) - is - -- Flags Use_TZ and Is_Historic are present for interfacing purposes - - pragma Unreferenced (Use_TZ, Is_Historic); - - procedure Numtim - (Status : out Unsigned_Longword; - Timbuf : out Unsigned_Word_Array; - Timadr : Time); - - pragma Import (External, Numtim); - - pragma Import_Valued_Procedure - (Numtim, "SYS$NUMTIM", - (Unsigned_Longword, Unsigned_Word_Array, Time), - (Value, Reference, Reference)); - - Status : Unsigned_Longword; - Timbuf : Unsigned_Word_Array (1 .. 7); - - Ada_Min_Year : constant := 1901; - Ada_Max_Year : constant := 2399; - - Date_M : OS_Time; - Elapsed_Leaps : Natural; - Next_Leap_M : OS_Time; - - begin - Date_M := OS_Time (Date); - - -- Step 1: Leap seconds processing - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M); - - Leap_Sec := Date_M >= Next_Leap_M; - - if Leap_Sec then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - Leap_Sec := False; - end if; - - Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili; - - -- Step 2: Time zone processing - - if Time_Zone /= 0 then - Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili; - end if; - - -- After the leap seconds and time zone have been accounted for, - -- the date should be within the bounds of Ada time. - - if Date_M < Ada_Low - or else Date_M > Ada_High - then - raise Time_Error; - end if; - - -- Step 3: Sub second processing - - Sub_Sec := Duration (Date_M mod Mili) / Mili_F; - - -- Drop the sub seconds - - Date_M := Date_M - (Date_M mod Mili); - - -- Step 4: VMS system call - - Numtim (Status, Timbuf, Time (Date_M)); - - if Status mod 2 /= 1 - or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year - then - raise Time_Error; - end if; - - -- Step 5: Time components processing - - Year := Year_Number (Timbuf (1)); - Month := Month_Number (Timbuf (2)); - Day := Day_Number (Timbuf (3)); - Hour := Integer (Timbuf (4)); - Minute := Integer (Timbuf (5)); - Second := Integer (Timbuf (6)); - - Day_Secs := Day_Duration (Hour * 3_600) + - Day_Duration (Minute * 60) + - Day_Duration (Second) + - Sub_Sec; - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time - is - -- Flag Is_Historic is present for interfacing purposes - - pragma Unreferenced (Is_Historic); - - procedure Cvt_Vectim - (Status : out Unsigned_Longword; - Input_Time : Unsigned_Word_Array; - Resultant_Time : out Time); - - pragma Import (External, Cvt_Vectim); - - pragma Import_Valued_Procedure - (Cvt_Vectim, "LIB$CVT_VECTIM", - (Unsigned_Longword, Unsigned_Word_Array, Time), - (Value, Reference, Reference)); - - Status : Unsigned_Longword; - Timbuf : Unsigned_Word_Array (1 .. 7); - - Y : Year_Number := Year; - Mo : Month_Number := Month; - D : Day_Number := Day; - H : Integer := Hour; - Mi : Integer := Minute; - Se : Integer := Second; - Su : Duration := Sub_Sec; - - Elapsed_Leaps : Natural; - Int_Day_Secs : Integer; - Next_Leap_M : OS_Time; - Res : Time; - Res_M : OS_Time; - Rounded_Res_M : OS_Time; - - begin - -- No validity checks are performed on the input values since it is - -- assumed that the called has already performed them. - - -- Step 1: Hour, minute, second and sub second processing - - if Use_Day_Secs then - - -- A day seconds value of 86_400 designates a new day - - if Day_Secs = 86_400.0 then - declare - Adj_Year : Year_Number := Year; - Adj_Month : Month_Number := Month; - Adj_Day : Day_Number := Day; - - begin - if Day < Days_In_Month (Month) - or else (Month = 2 - and then Is_Leap (Year)) - then - Adj_Day := Day + 1; - - -- The day adjustment moves the date to a new month - - else - Adj_Day := 1; - - if Month < 12 then - Adj_Month := Month + 1; - - -- The month adjustment moves the date to a new year - - else - Adj_Month := 1; - Adj_Year := Year + 1; - end if; - end if; - - Y := Adj_Year; - Mo := Adj_Month; - D := Adj_Day; - H := 0; - Mi := 0; - Se := 0; - Su := 0.0; - end; - - -- Normal case (not exactly one day) - - else - -- Sub second extraction - - Int_Day_Secs := - (if Day_Secs > 0.0 - then Integer (Day_Secs - 0.5) - else Integer (Day_Secs)); - - H := Int_Day_Secs / 3_600; - Mi := (Int_Day_Secs / 60) mod 60; - Se := Int_Day_Secs mod 60; - Su := Day_Secs - Duration (Int_Day_Secs); - end if; - end if; - - -- Step 2: System call to VMS - - Timbuf (1) := Unsigned_Word (Y); - Timbuf (2) := Unsigned_Word (Mo); - Timbuf (3) := Unsigned_Word (D); - Timbuf (4) := Unsigned_Word (H); - Timbuf (5) := Unsigned_Word (Mi); - Timbuf (6) := Unsigned_Word (Se); - Timbuf (7) := 0; - - Cvt_Vectim (Status, Timbuf, Res); - - if Status mod 2 /= 1 then - raise Time_Error; - end if; - - -- Step 3: Sub second adjustment - - Res_M := OS_Time (Res) + OS_Time (Su * Mili_F); - - -- Step 4: Bounds check - - Check_Within_Time_Bounds (Res_M); - - -- Step 5: Time zone processing - - if Time_Zone /= 0 then - Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili; - end if; - - -- Step 6: Leap seconds processing - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); - - Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili; - - -- An Ada 2005 caller requesting an explicit leap second or an - -- Ada 95 caller accounting for an invisible leap second. - - if Leap_Sec - or else Res_M >= Next_Leap_M - then - Res_M := Res_M + OS_Time (1) * Mili; - end if; - - -- Leap second validity check - - Rounded_Res_M := Res_M - (Res_M mod Mili); - - if Use_TZ - and then Leap_Sec - and then Rounded_Res_M /= Next_Leap_M - then - raise Time_Error; - end if; - end if; - - return Time (Res_M); - end Time_Of; - end Formatting_Operations; - - --------------------------- - -- Time_Zones_Operations -- - --------------------------- - - package body Time_Zones_Operations is - - --------------------- - -- UTC_Time_Offset -- - --------------------- - - function UTC_Time_Offset (Date : Time) return Long_Integer is - -- Formal parameter Date is here for interfacing, but is never - -- actually used. - - pragma Unreferenced (Date); - - function get_gmtoff return Long_Integer; - pragma Import (C, get_gmtoff, "get_gmtoff"); - - begin - -- VMS is not capable of determining the time zone in some past or - -- future point in time denoted by Date, thus the current time zone - -- is retrieved. - - return get_gmtoff; - end UTC_Time_Offset; - end Time_Zones_Operations; -end Ada.Calendar; diff --git a/main/gcc/ada/a-calend-vms.ads b/main/gcc/ada/a-calend-vms.ads deleted file mode 100644 index 744011ae008..00000000000 --- a/main/gcc/ada/a-calend-vms.ads +++ /dev/null @@ -1,310 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version - -with System.OS_Primitives; - -package Ada.Calendar is - - type Time is private; - - -- Declarations representing limits of allowed local time values. Note that - -- these do NOT constrain the possible stored values of time which may well - -- permit a larger range of times (this is explicitly allowed in Ada 95). - - subtype Year_Number is Integer range 1901 .. 2399; - subtype Month_Number is Integer range 1 .. 12; - subtype Day_Number is Integer range 1 .. 31; - - subtype Day_Duration is Duration range 0.0 .. 86_400.0; - -- Note that a value of 86_400.0 is the start of the next day - - function Clock return 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 - -- Ada time until now. - - function Year (Date : Time) return Year_Number; - function Month (Date : Time) return Month_Number; - function Day (Date : Time) return Day_Number; - function Seconds (Date : Time) return Day_Duration; - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration); - -- Break down a time value into its date components set in the current - -- time zone. If Split is called on a time value created using Ada 2005 - -- Time_Of in some arbitrary time zone, the input value will always be - -- interpreted as relative to the local time zone. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time; - -- GNAT Note: Normally when procedure Split is called on a Time value - -- result of a call to function Time_Of, the out parameters of procedure - -- Split are identical to the in parameters of function Time_Of. However, - -- when a non-existent time of day is specified, the values for Seconds - -- may or may not be different. This may happen when Daylight Saving Time - -- (DST) is in effect, on the day when switching to DST, if Seconds - -- specifies a time of day in the hour that does not exist. For example, - -- in New York: - -- - -- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0) - -- - -- will return a Time value T. If Split is called on T, the resulting - -- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being - -- a time that not exist). - - function "+" (Left : Time; Right : Duration) return Time; - function "+" (Left : Duration; Right : Time) return Time; - function "-" (Left : Time; Right : Duration) return Time; - function "-" (Left : Time; Right : Time) return Duration; - -- The first three functions will raise Time_Error if the resulting time - -- value is less than the start of Ada time in UTC or greater than the - -- end of Ada time in UTC. The last function will raise Time_Error if the - -- resulting difference cannot fit into a duration value. - - function "<" (Left, Right : Time) return Boolean; - function "<=" (Left, Right : Time) return Boolean; - function ">" (Left, Right : Time) return Boolean; - function ">=" (Left, Right : Time) return Boolean; - - Time_Error : exception; - -private - pragma Inline (Clock); - - pragma Inline (Year); - pragma Inline (Month); - pragma Inline (Day); - - pragma Inline ("+"); - pragma Inline ("-"); - - pragma Inline ("<"); - pragma Inline ("<="); - pragma Inline (">"); - pragma Inline (">="); - - -- Although the units are 100 nanoseconds, for the purpose of better - -- readability, this unit will be called "mili". - - Mili : constant := 10_000_000; - Mili_F : constant := 10_000_000.0; - Milis_In_Day : constant := 864_000_000_000; - Secs_In_Day : constant := 86_400; - - -- Time is represented as the number of 100-nanosecond (ns) units from the - -- system base date and time 1858-11-17 0.0 (the Smithsonian base date and - -- time for the astronomic calendar). - - -- The time value stored is typically a UTC value, as provided in standard - -- Unix environments. If this is the case then Split and Time_Of perform - -- required conversions to and from local times. - - -- Notwithstanding this definition, Time is not quite the same as OS_Time. - -- Relative Time is positive, whereas relative OS_Time is negative, - -- but this declaration makes for easier conversion. - - type Time is new System.OS_Primitives.OS_Time; - - Days_In_Month : constant array (Month_Number) of Day_Number := - (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); - -- Days in month for non-leap year, leap year case is adjusted in code - - Invalid_Time_Zone_Offset : Long_Integer; - pragma Import (C, Invalid_Time_Zone_Offset, "__gnat_invalid_tzoff"); - - function Is_Leap (Year : Year_Number) return Boolean; - -- Determine whether a given year is leap - - ---------------------------------------------------------- - -- Target-Independent Interface to Children of Calendar -- - ---------------------------------------------------------- - - -- The following packages provide a target-independent interface to the - -- children of Calendar - Arithmetic, Conversions, Delays, Formatting and - -- Time_Zones. - - -- NOTE: Delays does not need a target independent interface because - -- VMS already has a target specific file for that package. - - --------------------------- - -- Arithmetic_Operations -- - --------------------------- - - package Arithmetic_Operations is - - function Add (Date : Time; Days : Long_Integer) return Time; - -- Add a certain number of days to a time value - - procedure Difference - (Left : Time; - Right : Time; - Days : out Long_Integer; - Seconds : out Duration; - Leap_Seconds : out Integer); - -- Calculate the difference between two time values in terms of days, - -- seconds and leap seconds elapsed. The leap seconds are not included - -- in the seconds returned. If Left is greater than Right, the returned - -- values are positive, negative otherwise. - - function Subtract (Date : Time; Days : Long_Integer) return Time; - -- Subtract a certain number of days from a time value - - end Arithmetic_Operations; - - --------------------------- - -- Conversion_Operations -- - --------------------------- - - package Conversion_Operations is - - function To_Ada_Time (Unix_Time : Long_Integer) return Time; - -- Unix to Ada Epoch conversion - - function To_Ada_Time - (tm_year : Integer; - tm_mon : Integer; - tm_day : Integer; - tm_hour : Integer; - tm_min : Integer; - tm_sec : Integer; - tm_isdst : Integer) return Time; - -- Struct tm to Ada Epoch conversion - - function To_Duration - (tv_sec : Long_Integer; - tv_nsec : Long_Integer) return Duration; - -- Struct timespec to Duration conversion - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Long_Integer; - tv_nsec : out Long_Integer); - -- Duration to struct timespec conversion - - procedure To_Struct_Tm - (T : Time; - tm_year : out Integer; - tm_mon : out Integer; - tm_day : out Integer; - tm_hour : out Integer; - tm_min : out Integer; - tm_sec : out Integer); - -- Time to struct tm conversion - - function To_Unix_Time (Ada_Time : Time) return Long_Integer; - -- Ada to Unix Epoch conversion - - end Conversion_Operations; - - --------------------------- - -- Formatting_Operations -- - --------------------------- - - package Formatting_Operations is - - function Day_Of_Week (Date : Time) return Integer; - -- Determine which day of week Date falls on. The returned values are - -- within the range of 0 .. 6 (Monday .. Sunday). - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer); - pragma Export (Ada, Split, "__gnat_split"); - -- Split a time value into its components. If flag Is_Historic is set, - -- this routine would try to use to the best of the OS's abilities the - -- time zone offset that was or will be in effect on Date. Set Use_TZ - -- to use the local time zone (the value in Time_Zone is ignored) when - -- splitting a time value. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time; - pragma Export (Ada, Time_Of, "__gnat_time_of"); - -- Given all the components of a date, return the corresponding time - -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the - -- day duration will be calculated from Hour, Minute, Second and Sub_ - -- Sec. If flag Is_Historic is set, this routine would try to use to the - -- best of the OS's abilities the time zone offset that was or will be - -- in effect on the input date. Set Use_TZ to use the local time zone - -- (the value in formal Time_Zone is ignored) when building a time value - -- and to verify the validity of a requested leap second. - - end Formatting_Operations; - - --------------------------- - -- Time_Zones_Operations -- - --------------------------- - - package Time_Zones_Operations is - - function UTC_Time_Offset (Date : Time) return Long_Integer; - -- Return (in seconds) the difference between the local time zone and - -- UTC time at a specific historic date. - - end Time_Zones_Operations; - -end Ada.Calendar; diff --git a/main/gcc/ada/a-calend.adb b/main/gcc/ada/a-calend.adb index 0043a91e9fe..7c582ade3a0 100644 --- a/main/gcc/ada/a-calend.adb +++ b/main/gcc/ada/a-calend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ package body Ada.Calendar is -- by Integer in various routines. One ramification of this model is that -- the caller site must perform validity checks on returned results. -- The end result of this model is the lack of target specific files per - -- child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc). + -- child of Ada.Calendar (e.g. a-calfor). ----------------------- -- Local Subprograms -- diff --git a/main/gcc/ada/a-cbhase.adb b/main/gcc/ada/a-cbhase.adb index 6ea8e0ad0ef..331087b9eeb 100644 --- a/main/gcc/ada/a-cbhase.adb +++ b/main/gcc/ada/a-cbhase.adb @@ -1621,6 +1621,23 @@ package body Ada.Containers.Bounded_Hashed_Sets is -- Local Subprograms -- ----------------------- + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + L : Natural renames Control.Container.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Type) return Boolean; @@ -1632,11 +1649,11 @@ package body Ada.Containers.Bounded_Hashed_Sets is package Key_Keys is new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); ------------------------ @@ -1751,6 +1768,32 @@ package body Ada.Containers.Bounded_Hashed_Sets is HT_Ops.Free (Container, X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + L : Natural renames Control.Container.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + then + HT_Ops.Delete_Node_At_Index + (Control.Container.all, Control.Index, Control.Old_Pos.Node); + raise Program_Error with "key not preserved in reference"; + end if; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1815,14 +1858,24 @@ package body Ada.Containers.Bounded_Hashed_Sets is (Vet (Position), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - declare N : Node_Type renames Container.Nodes (Position.Node); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + begin - return (Element => N.Element'Access); + return R : constant Reference_Type := + (Element => N.Element'Unrestricted_Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => Key_Keys.Index (Container, Key (Position)), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; end; end Reference_Preserving_Key; @@ -1838,9 +1891,23 @@ package body Ada.Containers.Bounded_Hashed_Sets is end if; declare - N : Node_Type renames Container.Nodes (Node); + P : constant Cursor := Find (Container, Key); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; + begin - return (Element => N.Element'Access); + return R : constant Reference_Type := + (Element => Container.Nodes (Node).Element'Unrestricted_Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => Key_Keys.Index (Container, Key), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + B := B + 1; + L := L + 1; + end return; end; end Reference_Preserving_Key; diff --git a/main/gcc/ada/a-cbhase.ads b/main/gcc/ada/a-cbhase.ads index 40eea2f0efb..619aec9debc 100644 --- a/main/gcc/ada/a-cbhase.ads +++ b/main/gcc/ada/a-cbhase.ads @@ -444,8 +444,27 @@ package Ada.Containers.Bounded_Hashed_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type (Element : not null access Element_Type) is - null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; use Ada.Streams; diff --git a/main/gcc/ada/a-cbmutr.adb b/main/gcc/ada/a-cbmutr.adb index aa754149067..26b0085b648 100644 --- a/main/gcc/ada/a-cbmutr.adb +++ b/main/gcc/ada/a-cbmutr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +27,6 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ -with Ada.Finalization; use Ada.Finalization; - with System; use type System.Address; package body Ada.Containers.Bounded_Multiway_Trees is @@ -96,10 +94,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is procedure Allocate_Node (Container : in out Tree; - New_Node : out Count_Type); - - procedure Allocate_Node - (Container : in out Tree; Stream : not null access Root_Stream_Type'Class; New_Node : out Count_Type); @@ -240,6 +234,24 @@ package body Ada.Containers.Bounded_Multiway_Trees is Right_Subtree => Root_Node (Right)); end "="; + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------------- -- Allocate_Node -- ------------------- @@ -318,15 +330,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is Allocate_Node (Container, Initialize_Element'Access, New_Node); end Allocate_Node; - procedure Allocate_Node - (Container : in out Tree; - New_Node : out Count_Type) - is - procedure Initialize_Element (Index : Count_Type) is null; - begin - Allocate_Node (Container, Initialize_Element'Access, New_Node); - end Allocate_Node; - ------------------- -- Ancestor_Find -- ------------------- @@ -342,12 +345,6 @@ package body Ada.Containers.Bounded_Multiway_Trees is raise Constraint_Error with "Position cursor has no element"; end if; - -- Commented-out pending ruling by ARG. ??? - - -- if Position.Container /= Container'Unrestricted_Access then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - -- AI-0136 says to raise PE if Position equals the root node. This does -- not seem correct, as this value is just the limiting condition of the -- search. For now we omit this check, pending a ruling from the ARG. @@ -615,7 +612,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Container.Elements (Position.Node)'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements (Position.Node)'Access, + Control => (Controlled with Container'Unrestricted_Access)) + do + B := B + 1; + L := L + 1; + end return; + end; end Constant_Reference; -------------- @@ -1283,6 +1293,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is B := B - 1; end Finalize; + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + C : Tree renames Control.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + B := B - 1; + L := L - 1; + end; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1511,6 +1537,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type := 1) is Nodes : Tree_Node_Array renames Container.Nodes; + First : Count_Type; Last : Count_Type; begin @@ -1551,10 +1578,10 @@ package body Ada.Containers.Bounded_Multiway_Trees is Initialize_Root (Container); end if; - Allocate_Node (Container, New_Item, Position.Node); - Nodes (Position.Node).Parent := Parent.Node; + Allocate_Node (Container, New_Item, First); + Nodes (First).Parent := Parent.Node; - Last := Position.Node; + Last := First; for J in Count_Type'(2) .. Count loop Allocate_Node (Container, New_Item, Nodes (Last).Next); Nodes (Nodes (Last).Next).Parent := Parent.Node; @@ -1565,14 +1592,14 @@ package body Ada.Containers.Bounded_Multiway_Trees is Insert_Subtree_List (Container => Container, - First => Position.Node, + First => First, Last => Last, Parent => Parent.Node, Before => Before.Node); Container.Count := Container.Count + Count; - Position.Container := Parent.Container; + Position := Cursor'(Parent.Container, First); end Insert_Child; procedure Insert_Child @@ -1583,6 +1610,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is Count : Count_Type := 1) is Nodes : Tree_Node_Array renames Container.Nodes; + First : Count_Type; Last : Count_Type; New_Item : Element_Type; @@ -1633,12 +1661,12 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- initialization, so insert the specified number of possibly -- initialized elements at the given position. - Allocate_Node (Container, New_Item, Position.Node); - Nodes (Position.Node).Parent := Parent.Node; + Allocate_Node (Container, New_Item, First); + Nodes (First).Parent := Parent.Node; - Last := Position.Node; + Last := First; for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, Nodes (Last).Next); + Allocate_Node (Container, New_Item, Nodes (Last).Next); Nodes (Nodes (Last).Next).Parent := Parent.Node; Nodes (Nodes (Last).Next).Prev := Last; @@ -1647,14 +1675,14 @@ package body Ada.Containers.Bounded_Multiway_Trees is Insert_Subtree_List (Container => Container, - First => Position.Node, + First => First, Last => Last, Parent => Parent.Node, Before => Before.Node); Container.Count := Container.Count + Count; - Position.Container := Parent.Container; + Position := Cursor'(Parent.Container, First); end Insert_Child; ------------------------- @@ -2527,7 +2555,20 @@ package body Ada.Containers.Bounded_Multiway_Trees is -- pragma Assert (Vet (Position), -- "Position cursor in Constant_Reference is bad"); - return (Element => Container.Elements (Position.Node)'Access); + declare + C : Tree renames Position.Container.all; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Type := + (Element => Container.Elements (Position.Node)'Access, + Control => (Controlled with Position.Container)) + do + B := B + 1; + L := L + 1; + end return; + end; + end Reference; -------------------- diff --git a/main/gcc/ada/a-cbmutr.ads b/main/gcc/ada/a-cbmutr.ads index 2403164e8e9..7fe4b4e2ff5 100644 --- a/main/gcc/ada/a-cbmutr.ads +++ b/main/gcc/ada/a-cbmutr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2014, 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,6 +33,7 @@ with Ada.Iterator_Interfaces; private with Ada.Streams; +private with Ada.Finalization; generic type Element_Type is private; @@ -137,34 +138,10 @@ package Ada.Containers.Bounded_Multiway_Trees is (Container : Tree; Item : Element_Type) return Cursor; - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Find_In_Subtree this way: - -- - -- function Find_In_Subtree - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - function Find_In_Subtree (Position : Cursor; Item : Element_Type) return Cursor; - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Ancestor_Find this way: - -- - -- function Ancestor_Find - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - function Ancestor_Find (Position : Cursor; Item : Element_Type) return Cursor; @@ -284,20 +261,6 @@ package Ada.Containers.Bounded_Multiway_Trees is procedure Previous_Sibling (Position : in out Cursor); - -- This version of the AI: - - -- 10-06-02 AI05-0136-1/07 - - -- declares Iterate_Children this way: - - -- procedure Iterate_Children - -- (Container : Tree; - -- Parent : Cursor; - -- Process : not null access procedure (Position : Cursor)); - - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - procedure Iterate_Children (Parent : Cursor; Process : not null access procedure (Position : Cursor)); @@ -308,6 +271,7 @@ package Ada.Containers.Bounded_Multiway_Trees is private use Ada.Streams; + use Ada.Finalization; No_Node : constant Count_Type'Base := -1; -- Need to document all global declarations such as this ??? @@ -368,8 +332,22 @@ private Position : Cursor); for Cursor'Write use Write; + type Reference_Control_Type is + new Controlled with record + Container : Tree_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + type Constant_Reference_Type - (Element : not null access constant Element_Type) is null record; + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; @@ -382,7 +360,10 @@ private for Constant_Reference_Type'Read use Read; type Reference_Type - (Element : not null access Element_Type) is null record; + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type; + end record; procedure Write (Stream : not null access Root_Stream_Type'Class; diff --git a/main/gcc/ada/a-cborse.adb b/main/gcc/ada/a-cborse.adb index ea6a6d06af1..979357ddc75 100644 --- a/main/gcc/ada/a-cborse.adb +++ b/main/gcc/ada/a-cborse.adb @@ -482,6 +482,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is raise Program_Error with "Position cursor designates wrong set"; end if; + if Container.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + pragma Assert (Vet (Container, Position.Node), "bad cursor in Delete"); @@ -495,11 +500,12 @@ package body Ada.Containers.Bounded_Ordered_Sets is X : constant Count_Type := Element_Keys.Find (Container, Item); begin + Tree_Operations.Delete_Node_Sans_Free (Container, X); + if X = 0 then raise Constraint_Error with "attempt to delete element not in set"; end if; - Tree_Operations.Delete_Node_Sans_Free (Container, X); Tree_Operations.Free (Container, X); end Delete; @@ -734,6 +740,23 @@ package body Ada.Containers.Bounded_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + L : Natural renames Control.Container.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------- -- Ceiling -- ------------- @@ -842,6 +865,30 @@ package body Ada.Containers.Bounded_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + L : Natural renames Control.Container.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if not (Key (Control.Pos) = Control.Old_Key.all) then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -939,14 +986,22 @@ package body Ada.Containers.Bounded_Ordered_Sets is (Vet (Container, Position.Node), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - declare N : Node_Type renames Container.Nodes (Position.Node); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin - return (Element => N.Element'Access); + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; end; end Reference_Preserving_Key; @@ -963,8 +1018,20 @@ package body Ada.Containers.Bounded_Ordered_Sets is declare N : Node_Type renames Container.Nodes (Node); + B : Natural renames Container.Busy; + L : Natural renames Container.Lock; begin - return (Element => N.Element'Access); + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + B := B + 1; + L := L + 1; + end return; end; end Reference_Preserving_Key; @@ -1181,6 +1248,11 @@ package body Ada.Containers.Bounded_Ordered_Sets is -- Start of processing for Insert_Sans_Hint begin + if Container.Busy > 0 then + raise Program_Error with + "attemot to tamper with cursors (set is busy)"; + end if; + Conditional_Insert_Sans_Hint (Container, New_Item, diff --git a/main/gcc/ada/a-cborse.ads b/main/gcc/ada/a-cborse.ads index 03fdd49aaa7..09cb6510b2c 100644 --- a/main/gcc/ada/a-cborse.ads +++ b/main/gcc/ada/a-cborse.ads @@ -277,11 +277,31 @@ package Ada.Containers.Bounded_Ordered_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type (Element : not null access Element_Type) is - null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; use Ada.Streams; + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; + procedure Read (Stream : not null access Root_Stream_Type'Class; Item : out Reference_Type); diff --git a/main/gcc/ada/a-cfhama.adb b/main/gcc/ada/a-cfhama.adb index ea506d8ddc4..1780bbb3027 100644 --- a/main/gcc/ada/a-cfhama.adb +++ b/main/gcc/ada/a-cfhama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); 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.Formal_Hashed_Maps is + pragma SPARK_Mode (Off); ----------------------- -- Local Subprograms -- @@ -144,7 +145,7 @@ package body Ada.Containers.Formal_Hashed_Maps is procedure Insert_Element (Source_Node : Count_Type) is N : Node_Type renames Source.Nodes (Source_Node); begin - Target.Insert (N.Key, N.Element); + Insert (Target, N.Key, N.Element); end Insert_Element; -- Start of processing for Assign diff --git a/main/gcc/ada/a-cfhama.ads b/main/gcc/ada/a-cfhama.ads index 9a2b37690dd..b5c440ec74d 100644 --- a/main/gcc/ada/a-cfhama.ads +++ b/main/gcc/ada/a-cfhama.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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 -- @@ -68,6 +68,7 @@ generic package Ada.Containers.Formal_Hashed_Maps is pragma Annotate (GNATprove, External_Axiomatization); pragma Pure; + pragma SPARK_Mode (On); type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with Iterable => (First => First, @@ -276,6 +277,7 @@ private pragma Inline (Has_Element); pragma Inline (Equivalent_Keys); pragma Inline (Next); + pragma SPARK_Mode (Off); type Node_Type is record Key : Key_Type; @@ -285,11 +287,10 @@ private end record; package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types - (Node_Type); + Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); type Map (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; diff --git a/main/gcc/ada/a-cfhase.adb b/main/gcc/ada/a-cfhase.adb index de09ce84f9b..7c1f9541f6c 100644 --- a/main/gcc/ada/a-cfhase.adb +++ b/main/gcc/ada/a-cfhase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +36,7 @@ with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; with System; use type System.Address; package body Ada.Containers.Formal_Hashed_Sets is + pragma SPARK_Mode (Off); ----------------------- -- Local Subprograms -- diff --git a/main/gcc/ada/a-cfhase.ads b/main/gcc/ada/a-cfhase.ads index 4e54ef97832..2a2f4e87637 100644 --- a/main/gcc/ada/a-cfhase.ads +++ b/main/gcc/ada/a-cfhase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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,6 +70,7 @@ generic package Ada.Containers.Formal_Hashed_Sets is pragma Annotate (GNATprove, External_Axiomatization); pragma Pure; + pragma SPARK_Mode (On); type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with Iterable => (First => First, @@ -329,8 +330,8 @@ package Ada.Containers.Formal_Hashed_Sets is -- scanned yet. private - pragma Inline (Next); + pragma SPARK_Mode (Off); type Node_Type is record @@ -343,7 +344,7 @@ private Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); type Set (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; use HT_Types; diff --git a/main/gcc/ada/a-cforma.adb b/main/gcc/ada/a-cforma.adb index 69f2cc7b6d7..8a85cae8fd4 100644 --- a/main/gcc/ada/a-cforma.adb +++ b/main/gcc/ada/a-cforma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Maps is + pragma SPARK_Mode (Off); ----------------------------- -- Node Access Subprograms -- diff --git a/main/gcc/ada/a-cforma.ads b/main/gcc/ada/a-cforma.ads index 64d77fa4c8d..e9a5f976e91 100644 --- a/main/gcc/ada/a-cforma.ads +++ b/main/gcc/ada/a-cforma.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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,6 +69,7 @@ generic package Ada.Containers.Formal_Ordered_Maps is pragma Annotate (GNATprove, External_Axiomatization); pragma Pure; + pragma SPARK_Mode (On); function Equivalent_Keys (Left, Right : Key_Type) return Boolean with Global => null; @@ -265,10 +266,11 @@ package Ada.Containers.Formal_Ordered_Maps is function Overlap (Left, Right : Map) return Boolean with Global => null; -- Overlap returns True if the containers have common keys -private +private pragma Inline (Next); pragma Inline (Previous); + pragma SPARK_Mode (Off); subtype Node_Access is Count_Type; @@ -288,7 +290,7 @@ private new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); type Map (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; + new Tree_Types.Tree_Type (Capacity) with null record; type Cursor is record Node : Node_Access; diff --git a/main/gcc/ada/a-cforse.adb b/main/gcc/ada/a-cforse.adb index bc8ffbaac88..966853a1828 100644 --- a/main/gcc/ada/a-cforse.adb +++ b/main/gcc/ada/a-cforse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 +36,10 @@ with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); -with System; use type System.Address; +with System; use type System.Address; package body Ada.Containers.Formal_Ordered_Sets is + pragma SPARK_Mode (Off); ------------------------------ -- Access to Fields of Node -- @@ -1534,8 +1535,8 @@ package body Ada.Containers.Formal_Ordered_Sets is end if; return S : Set (Length (Left) + Length (Right)) do - S.Assign (Source => Left); - S.Union (Right); + Assign (S, Source => Left); + Union (S, Right); end return; end Union; diff --git a/main/gcc/ada/a-cforse.ads b/main/gcc/ada/a-cforse.ads index 8d3189edaec..dc174070023 100644 --- a/main/gcc/ada/a-cforse.ads +++ b/main/gcc/ada/a-cforse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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 -- @@ -67,6 +67,7 @@ generic package Ada.Containers.Formal_Ordered_Sets is pragma Annotate (GNATprove, External_Axiomatization); pragma Pure; + pragma SPARK_Mode (On); function Equivalent_Elements (Left, Right : Element_Type) return Boolean with @@ -347,9 +348,9 @@ package Ada.Containers.Formal_Ordered_Sets is -- scanned yet. private - pragma Inline (Next); pragma Inline (Previous); + pragma SPARK_Mode (Off); type Node_Type is record Has_Element : Boolean := False; diff --git a/main/gcc/ada/a-chtgbo.adb b/main/gcc/ada/a-chtgbo.adb index c455741fae8..d114bc8bb04 100644 --- a/main/gcc/ada/a-chtgbo.adb +++ b/main/gcc/ada/a-chtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +81,49 @@ package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is HT.Buckets := (others => 0); -- optimize this somehow ??? end Clear; + -------------------------- + -- Delete_Node_At_Index -- + -------------------------- + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type) + is + Prev : Count_Type; + Curr : Count_Type; + + begin + Prev := HT.Buckets (Indx); + + if Prev = 0 then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (HT.Nodes (Prev)); + HT.Length := HT.Length - 1; + return; + end if; + + if HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (HT.Nodes (Prev)); + + if Curr = 0 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + Prev := Curr; + end loop; + end Delete_Node_At_Index; + --------------------------- -- Delete_Node_Sans_Free -- --------------------------- diff --git a/main/gcc/ada/a-chtgbo.ads b/main/gcc/ada/a-chtgbo.ads index 0e9e9284018..5019154205d 100644 --- a/main/gcc/ada/a-chtgbo.ads +++ b/main/gcc/ada/a-chtgbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,16 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is -- the nodes, not the buckets array.) Program_Error is raised if the hash -- table is busy. + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type); + -- Delete a node whose bucket position is known. extracted from following + -- subprogram, but also used directly to remove a node whose element has + -- been modified through a key_preserving reference: in that case we cannot + -- use the value of the element precisely because the current value does + -- not correspond to the hash code that determines its bucket. + procedure Delete_Node_Sans_Free (HT : in out Hash_Table_Type'Class; X : Count_Type); diff --git a/main/gcc/ada/a-chtgop.adb b/main/gcc/ada/a-chtgop.adb index 4227c8f4483..dda5f2cccf7 100644 --- a/main/gcc/ada/a-chtgop.adb +++ b/main/gcc/ada/a-chtgop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,52 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is end loop; end Clear; + -------------------------- + -- Delete_Node_At_Index -- + -------------------------- + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type; + Indx : Hash_Type; + X : in out Node_Access) + is + Prev : Node_Access; + Curr : Node_Access; + + begin + Prev := HT.Buckets (Indx); + + if Prev = X then + HT.Buckets (Indx) := Next (Prev); + HT.Length := HT.Length - 1; + Free (X); + return; + end if; + + if HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (Prev); + + if Curr = null then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + if Curr = X then + Set_Next (Node => Prev, Next => Next (Curr)); + HT.Length := HT.Length - 1; + Free (X); + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_At_Index; + --------------------------- -- Delete_Node_Sans_Free -- --------------------------- diff --git a/main/gcc/ada/a-chtgop.ads b/main/gcc/ada/a-chtgop.ads index c8e22c30ca5..70e1535c86a 100644 --- a/main/gcc/ada/a-chtgop.ads +++ b/main/gcc/ada/a-chtgop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +128,15 @@ package Ada.Containers.Hash_Tables.Generic_Operations is -- rehashed onto the new buckets array, and the old buckets array is -- deallocated. Program_Error is raised if the hash table is busy. + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type; + Indx : Hash_Type; + X : in out Node_Access); + -- Delete a node whose bucket position is known. Used to remove a node + -- whose element has been modified through a key_preserving reference. + -- We cannot use the value of the element precisely because the current + -- value does not correspond to the hash code that determines the bucket. + procedure Delete_Node_Sans_Free (HT : in out Hash_Table_Type; X : Node_Access); @@ -163,8 +172,9 @@ package Ada.Containers.Hash_Tables.Generic_Operations is generic use Ada.Streams; - with function New_Node (Stream : not null access Root_Stream_Type'Class) - return Node_Access; + with function New_Node + (Stream : not null access Root_Stream_Type'Class) + return Node_Access; procedure Generic_Read (Stream : not null access Root_Stream_Type'Class; HT : out Hash_Table_Type); @@ -174,7 +184,7 @@ package Ada.Containers.Hash_Tables.Generic_Operations is function New_Buckets (Length : Hash_Type) return Buckets_Access; pragma Inline (New_Buckets); - -- Allocate a new Buckets_Type array with bounds 0..Length-1 + -- Allocate a new Buckets_Type array with bounds 0 .. Length - 1 procedure Free_Buckets (Buckets : in out Buckets_Access); pragma Inline (Free_Buckets); diff --git a/main/gcc/ada/a-cihase.adb b/main/gcc/ada/a-cihase.adb index 87c4ac47d5c..7d503668702 100644 --- a/main/gcc/ada/a-cihase.adb +++ b/main/gcc/ada/a-cihase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2139,6 +2139,24 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Hash => Hash, Equivalent_Keys => Equivalent_Key_Node); + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------------------ -- Constant_Reference -- ------------------------ @@ -2249,6 +2267,32 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Free (X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if Hash (Key (Control.Old_Pos)) /= Control.Old_Hash then + HT_Ops.Delete_Node_At_Index + (Control.Container.HT, Control.Index, Control.Old_Pos.Node); + raise Program_Error; + end if; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -2322,19 +2366,31 @@ package body Ada.Containers.Indefinite_Hashed_Sets is (Vet (Position), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - - return (Element => Position.Node.Element.all'Access); + declare + HT : Hash_Table_Type renames Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with + Container => Container'Access, + Index => HT_Ops.Index (HT, Position.Node), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; function Reference_Preserving_Key (Container : aliased in out Set; Key : Key_Type) return Reference_Type is - Node : constant Node_Access := - Key_Keys.Find (Container.HT, Key); + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin if Node = null then @@ -2345,11 +2401,25 @@ package body Ada.Containers.Indefinite_Hashed_Sets is raise Program_Error with "Node has no element"; end if; - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Key has not - -- changed. ??? - - return (Element => Node.Element.all'Access); + declare + HT : Hash_Table_Type renames Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + P : constant Cursor := Find (Container, Key); + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with + Container => Container'Access, + Index => HT_Ops.Index (HT, P.Node), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; ------------- @@ -2361,8 +2431,7 @@ package body Ada.Containers.Indefinite_Hashed_Sets is Key : Key_Type; New_Item : Element_Type) is - Node : constant Node_Access := - Key_Keys.Find (Container.HT, Key); + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); begin if Node = null then diff --git a/main/gcc/ada/a-cihase.ads b/main/gcc/ada/a-cihase.ads index 2c4dec59996..05af6bf32ed 100644 --- a/main/gcc/ada/a-cihase.ads +++ b/main/gcc/ada/a-cihase.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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 -- @@ -430,8 +430,27 @@ package Ada.Containers.Indefinite_Hashed_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type (Element : not null access Element_Type) - is null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; use Ada.Streams; diff --git a/main/gcc/ada/a-ciorse.adb b/main/gcc/ada/a-ciorse.adb index b79d27e8b15..7c14cac72cb 100644 --- a/main/gcc/ada/a-ciorse.adb +++ b/main/gcc/ada/a-ciorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -768,6 +768,24 @@ package body Ada.Containers.Indefinite_Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------- -- Ceiling -- ------------- @@ -878,6 +896,32 @@ package body Ada.Containers.Indefinite_Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if not (Key (Control.Pos) = Control.Old_Key.all) then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + Control.Old_Key := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -1004,11 +1048,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is (Vet (Container.Tree, Position.Node), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - - return (Element => Position.Node.Element.all'Access); + declare + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Unchecked_Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; function Reference_Preserving_Key @@ -1026,11 +1082,23 @@ package body Ada.Containers.Indefinite_Ordered_Sets is raise Program_Error with "Node has no element"; end if; - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Key has not - -- changed. ??? - - return (Element => Node.Element.all'Access); + declare + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Unchecked_Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; ----------------------------------- diff --git a/main/gcc/ada/a-ciorse.ads b/main/gcc/ada/a-ciorse.ads index 0dba13e42ed..830f9886624 100644 --- a/main/gcc/ada/a-ciorse.ads +++ b/main/gcc/ada/a-ciorse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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 -- @@ -293,8 +293,28 @@ package Ada.Containers.Indefinite_Ordered_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type - (Element : not null access Element_Type) is null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; use Ada.Streams; diff --git a/main/gcc/ada/a-cohase.adb b/main/gcc/ada/a-cohase.adb index 1c3db68f807..f7f49aab96c 100644 --- a/main/gcc/ada/a-cohase.adb +++ b/main/gcc/ada/a-cohase.adb @@ -824,6 +824,11 @@ package body Ada.Containers.Hashed_Sets is HT_Ops.Reserve_Capacity (HT, 1); end if; + if HT.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors (set is busy)"; + end if; + Local_Insert (HT, New_Item, Node, Inserted); if Inserted @@ -1921,6 +1926,24 @@ package body Ada.Containers.Hashed_Sets is -- Local Subprograms -- ----------------------- + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + function Equivalent_Key_Node (Key : Key_Type; Node : Node_Access) return Boolean; @@ -2046,6 +2069,33 @@ package body Ada.Containers.Hashed_Sets is Free (X); end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + HT : Hash_Table_Type renames Control.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + then + HT_Ops.Delete_Node_At_Index + (Control.Container.HT, Control.Index, Control.Old_Pos.Node); + raise Program_Error with "key not preserved in reference"; + end if; + + Control.Container := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -2056,13 +2106,12 @@ package body Ada.Containers.Hashed_Sets is is HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; Node : constant Node_Access := Key_Keys.Find (HT, Key); - begin if Node = null then return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); end if; - - return Cursor'(Container'Unrestricted_Access, Node); end Find; --------- @@ -2115,11 +2164,24 @@ package body Ada.Containers.Hashed_Sets is (Vet (Position), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? - - return (Element => Position.Node.Element'Access); + declare + HT : Hash_Table_Type renames Position.Container.all.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => HT_Ops.Index (HT, Position.Node), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; function Reference_Preserving_Key @@ -2130,14 +2192,28 @@ package body Ada.Containers.Hashed_Sets is begin if Node = null then - raise Constraint_Error with "Key not in set"; + raise Constraint_Error with "key not in set"; end if; - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Key has not - -- changed. ??? - - return (Element => Node.Element'Access); + declare + HT : Hash_Table_Type renames Container.HT; + B : Natural renames HT.Busy; + L : Natural renames HT.Lock; + P : constant Cursor := Find (Container, Key); + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with + Container'Unrestricted_Access, + Index => HT_Ops.Index (HT, P.Node), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; ------------- diff --git a/main/gcc/ada/a-cohase.ads b/main/gcc/ada/a-cohase.ads index 9c112fa3ee2..a9990ce6b8d 100644 --- a/main/gcc/ada/a-cohase.ads +++ b/main/gcc/ada/a-cohase.ads @@ -34,8 +34,8 @@ with Ada.Iterator_Interfaces; private with Ada.Containers.Hash_Tables; -private with Ada.Streams; private with Ada.Finalization; +private with Ada.Streams; generic type Element_Type is private; @@ -433,10 +433,42 @@ package Ada.Containers.Hashed_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type (Element : not null access Element_Type) - is null record; - use Ada.Streams; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + -- Key_Preserving references must carry information to allow removal + -- of elements whose value may have been altered improperly, i.e. have + -- been given values incompatible with the hash-code of the previous + -- value, and are thus in the wrong bucket. (RM 18.7 (96.6/3)) + + -- We cannot store the key directly because it is an unconstrained type. + -- To avoid using additional dynamic allocation we store the old cursor + -- which simplifies possible removal. This is not possible for some + -- other set types. + + -- The mechanism is different for Update_Element_Preserving_Key, as + -- in that case the check that buckets have not changed is performed + -- at the time of the update, not when the reference is finalized. + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; procedure Read (Stream : not null access Root_Stream_Type'Class; @@ -449,7 +481,6 @@ package Ada.Containers.Hashed_Sets is Item : Reference_Type); for Reference_Type'Write use Write; - end Generic_Keys; private @@ -498,6 +529,10 @@ private Node : Node_Access; end record; + type Reference_Control_Type is new Ada.Finalization.Controlled with record + Container : Set_Access; + end record; + procedure Write (Stream : not null access Root_Stream_Type'Class; Item : Cursor); @@ -510,11 +545,6 @@ private for Cursor'Read use Read; - type Reference_Control_Type is - new Controlled with record - Container : Set_Access; - end record; - overriding procedure Adjust (Control : in out Reference_Control_Type); pragma Inline (Adjust); diff --git a/main/gcc/ada/a-comutr.ads b/main/gcc/ada/a-comutr.ads index 6e0aa9a1203..c1a3dc85cd5 100644 --- a/main/gcc/ada/a-comutr.ads +++ b/main/gcc/ada/a-comutr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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 -- @@ -308,17 +308,16 @@ package Ada.Containers.Multiway_Trees is Process : not null access procedure (Position : Cursor)); private - -- A node of this multiway tree comprises an element and a list of children -- (that are themselves trees). The root node is distinguished because it -- contains only children: it does not have an element itself. - -- - -- This design feature puts two design goals in tension: + + -- This design feature puts two design goals in tension with one another: -- (1) treat the root node the same as any other node -- (2) not declare any objects of type Element_Type unnecessarily - -- - -- To satisfy (1), we could simply declare the Root node of the tree using - -- the normal Tree_Node_Type, but that would mean that (2) is not + + -- To satisfy (1), we could simply declare the Root node of the tree + -- using the normal Tree_Node_Type, but that would mean that (2) is not -- satisfied. To resolve the tension (in favor of (2)), we declare the -- component Root as having a different node type, without an Element -- component (thus satisfying goal (2)) but otherwise identical to a normal @@ -327,11 +326,11 @@ private -- normal, non-root node (thus satisfying goal (1)). We make an explicit -- check for Root when there is any attempt to manipulate the Element -- component of the node (a check required by the RM anyway). - -- + -- In order to be explicit about node (and pointer) representation, we - -- specify that the respective node types have convention C, to ensure that - -- the layout of the components of the node records is the same, thus - -- guaranteeing that (unchecked) conversions between access types + -- specify that the respective node types have convention C, to ensure + -- that the layout of the components of the node records is the same, + -- thus guaranteeing that (unchecked) conversions between access types -- designating each kind of node type is a meaningful conversion. type Tree_Node_Type; @@ -366,6 +365,11 @@ private end record; pragma Convention (C, Root_Node_Type); + for Root_Node_Type'Alignment use Standard'Maximum_Alignment; + -- The alignment has to be large enough to allow Root_Node to Tree_Node + -- access value conversions, and Tree_Node_Type's alignment may be bumped + -- up by the Element component. + use Ada.Finalization; -- The Count component of type Tree represents the number of nodes that diff --git a/main/gcc/ada/a-coorse.adb b/main/gcc/ada/a-coorse.adb index 675b40fcc39..0f45308d669 100644 --- a/main/gcc/ada/a-coorse.adb +++ b/main/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -690,6 +690,24 @@ package body Ada.Containers.Ordered_Sets is Is_Less_Key_Node => Is_Less_Key_Node, Is_Greater_Key_Node => Is_Greater_Key_Node); + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B + 1; + L := L + 1; + end; + end if; + end Adjust; + ------------- -- Ceiling -- ------------- @@ -793,6 +811,32 @@ package body Ada.Containers.Ordered_Sets is end if; end Exclude; + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + Tree : Tree_Type renames Control.Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; + begin + B := B - 1; + L := L - 1; + end; + + if not (Key (Control.Pos) = Control.Old_Key.all) then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + Control.Old_Key := null; + end if; + end Finalize; + ---------- -- Find -- ---------- @@ -890,11 +934,24 @@ package body Ada.Containers.Ordered_Sets is (Vet (Container.Tree, Position.Node), "bad cursor in function Reference_Preserving_Key"); - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? + declare + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; - return (Element => Position.Node.Element'Access); + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; function Reference_Preserving_Key @@ -908,11 +965,24 @@ package body Ada.Containers.Ordered_Sets is raise Constraint_Error with "key not in set"; end if; - -- Some form of finalization will be required in order to actually - -- check that the key-part of the element designated by Position has - -- not changed. ??? + declare + Tree : Tree_Type renames Container.Tree; + B : Natural renames Tree.Busy; + L : Natural renames Tree.Lock; - return (Element => Node.Element'Access); + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + B := B + 1; + L := L + 1; + end return; + end; end Reference_Preserving_Key; ------------- diff --git a/main/gcc/ada/a-coorse.ads b/main/gcc/ada/a-coorse.ads index cf0110c74c2..315134554e9 100644 --- a/main/gcc/ada/a-coorse.ads +++ b/main/gcc/ada/a-coorse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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 -- @@ -278,8 +278,28 @@ package Ada.Containers.Ordered_Sets is Key : Key_Type) return Reference_Type; private - type Reference_Type - (Element : not null access Element_Type) is null record; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; + + type Reference_Control_Type is + new Ada.Finalization.Controlled with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; use Ada.Streams; diff --git a/main/gcc/ada/a-crdlli.ads b/main/gcc/ada/a-crdlli.ads index f2b58656749..c18005fc720 100644 --- a/main/gcc/ada/a-crdlli.ads +++ b/main/gcc/ada/a-crdlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -321,8 +321,6 @@ private Length : Count_Type := 0; end record; - Empty_List : constant List := (0, others => <>); - type List_Access is access all List; for List_Access'Storage_Size use 0; @@ -332,6 +330,8 @@ private Node : Count_Type := 0; end record; + Empty_List : constant List := (0, others => <>); + No_Element : constant Cursor := (null, 0); end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/main/gcc/ada/a-direct.adb b/main/gcc/ada/a-direct.adb index c6d2b7ceda3..f567984a679 100644 --- a/main/gcc/ada/a-direct.adb +++ b/main/gcc/ada/a-direct.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -982,7 +982,6 @@ package body Ada.Directories is Hour : Hour_Type; Minute : Minute_Type; Second : Second_Type; - Result : Time; begin -- First, the invalid cases @@ -999,25 +998,11 @@ package body Ada.Directories is GM_Split (Date, Year, Month, Day, Hour, Minute, Second); - -- On OpenVMS, the resulting time value must be in the local time - -- zone. Ada.Calendar.Time_Of is exactly what we need. Note that - -- in both cases, the sub seconds are set to zero (0.0) because the - -- time stamp does not store them in its value. - - if OpenVMS then - Result := - Ada.Calendar.Time_Of - (Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0)); - - -- On Unix and Windows, the result must be in GMT. Ada.Calendar. + -- The result must be in GMT. Ada.Calendar. -- Formatting.Time_Of with default time zone of zero (0) is the -- routine of choice. - else - Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); - end if; - - return Result; + return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); end if; end Modification_Time; @@ -1250,7 +1235,7 @@ package body Ada.Directories is function Size (Name : String) return File_Size is C_Name : String (1 .. Name'Length + 1); - function C_Size (Name : Address) return Long_Integer; + function C_Size (Name : Address) return int64; pragma Import (C, C_Size, "__gnat_named_file_length"); begin diff --git a/main/gcc/ada/a-direct.ads b/main/gcc/ada/a-direct.ads index 9e2f880c4a8..a308c004925 100644 --- a/main/gcc/ada/a-direct.ads +++ b/main/gcc/ada/a-direct.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived for use with GNAT from AI-00248, which is -- -- expected to be a part of a future expected revised Ada Reference Manual. -- @@ -81,7 +81,7 @@ package Ada.Directories is function Current_Directory return String; -- Returns the full directory name for the current default directory. The - -- name returned shall be suitable for a future call to Set_Directory. + -- name returned must be suitable for a future call to Set_Directory. -- The exception Use_Error is propagated if a default directory is not -- supported by the external environment. @@ -121,15 +121,15 @@ package Ada.Directories is -- Creates zero or more directories with name New_Directory. Each -- non-existent directory named by New_Directory is created. For example, -- on a typical Unix system, Create_Path ("/usr/me/my"); would create - -- directory "me" in directory "usr", then create directory "my" in - -- directory "me". The Form can be used to give system-dependent + -- directory "me" in directory "usr", then create directory "my" + -- in directory "me". The Form can be used to give system-dependent -- characteristics of the directory; the interpretation of the Form -- parameter is implementation-defined. A null string for Form specifies -- the use of the default options of the implementation of the new -- directory. The exception Name_Error is propagated if the string given - -- as New_Directory does not allow the identification of any directory. - -- The exception Use_Error is propagated if the external environment does - -- not support the creation of any directories with the given name (in the + -- as New_Directory does not allow the identification of any directory. The + -- exception Use_Error is propagated if the external environment does not + -- support the creation of any directories with the given name (in the -- absence of Name_Error) and form. -- -- The Form parameter is ignored @@ -139,9 +139,9 @@ package Ada.Directories is -- all of its contents (possibly including other directories) are deleted. -- The exception Name_Error is propagated if the string given as Directory -- does not identify an existing directory. The exception Use_Error is - -- propagated if the external environment does not support the deletion of - -- the directory or some portion of its contents with the given name (in - -- the absence of Name_Error). If Use_Error is propagated, it is + -- propagated if the external environment does not support the deletion + -- of the directory or some portion of its contents with the given name + -- (in the absence of Name_Error). If Use_Error is propagated, it is -- unspecified if a portion of the contents of the directory are deleted. procedure Delete_File (Name : String); diff --git a/main/gcc/ada/a-dirval-mingw.adb b/main/gcc/ada/a-dirval-mingw.adb index 205f128cdaf..d7d77622db7 100644 --- a/main/gcc/ada/a-dirval-mingw.adb +++ b/main/gcc/ada/a-dirval-mingw.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Windows Version) -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -162,15 +162,6 @@ package body Ada.Directories.Validity is end Is_Valid_Simple_Name; ------------- - -- OpenVMS -- - ------------- - - function OpenVMS return Boolean is - begin - return False; - end OpenVMS; - - ------------- -- Windows -- ------------- diff --git a/main/gcc/ada/a-dirval-vms.adb b/main/gcc/ada/a-dirval-vms.adb deleted file mode 100644 index c9a08310d74..00000000000 --- a/main/gcc/ada/a-dirval-vms.adb +++ /dev/null @@ -1,200 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (VMS Version) -- --- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version of this package - -package body Ada.Directories.Validity is - - Max_Number_Of_Characters : constant := 39; - Max_Path_Length : constant := 1_024; - - Invalid_Character : constant array (Character) of Boolean := - ('a' .. 'z' => False, - 'A' .. 'Z' => False, - '0' .. '9' => False, - '_' | '$' | '-' | '.' => False, - others => True); - - --------------------------------- - -- Is_Path_Name_Case_Sensitive -- - --------------------------------- - - function Is_Path_Name_Case_Sensitive return Boolean is - begin - return False; - end Is_Path_Name_Case_Sensitive; - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - First : Positive := Name'First; - Last : Positive; - Dot_Found : Boolean := False; - - begin - -- A valid path (directory) name cannot be empty, and cannot contain - -- more than 1024 characters. Directories can be ".", ".." or be simple - -- name without extensions. - - if Name'Length = 0 or else Name'Length > Max_Path_Length then - return False; - - else - loop - -- Look for the start of the next directory or file name - - while First <= Name'Last and then Name (First) = '/' loop - First := First + 1; - end loop; - - -- If all directories/file names are OK, return True - - exit when First > Name'Last; - - Last := First; - Dot_Found := False; - - -- Look for the end of the directory/file name - - while Last < Name'Last loop - exit when Name (Last + 1) = '/'; - Last := Last + 1; - - if Name (Last) = '.' then - Dot_Found := True; - end if; - end loop; - - -- If name include a dot, it can only be ".", ".." or the last - -- file name. - - if Dot_Found then - if Name (First .. Last) /= "." and then - Name (First .. Last) /= ".." - then - return Last = Name'Last - and then Is_Valid_Simple_Name (Name (First .. Last)); - - end if; - - -- Check if the directory/file name is valid - - elsif not Is_Valid_Simple_Name (Name (First .. Last)) then - return False; - end if; - - -- Move to the next name - - First := Last + 1; - end loop; - end if; - - -- If Name follows the rules, then it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - In_Extension : Boolean := False; - Number_Of_Characters : Natural := 0; - - begin - -- A file name cannot be empty, and cannot have more than 39 characters - -- before or after a single '.'. - - if Name'Length = 0 then - return False; - - else - -- Check each character for validity - - for J in Name'Range loop - if Invalid_Character (Name (J)) then - return False; - - elsif Name (J) = '.' then - - -- Name cannot contain several dots - - if In_Extension then - return False; - - else - -- Reset the number of characters to count the characters - -- of the extension. - - In_Extension := True; - Number_Of_Characters := 0; - end if; - - else - -- Check that the number of character is not too large - - Number_Of_Characters := Number_Of_Characters + 1; - - if Number_Of_Characters > Max_Number_Of_Characters then - return False; - end if; - end if; - end loop; - end if; - - -- If the rules are followed, then it is valid - - return True; - end Is_Valid_Simple_Name; - - ------------- - -- OpenVMS -- - ------------- - - function OpenVMS return Boolean is - begin - return True; - end OpenVMS; - - ------------- - -- Windows -- - ------------- - - function Windows return Boolean is - begin - return False; - end Windows; - -end Ada.Directories.Validity; diff --git a/main/gcc/ada/a-dirval.adb b/main/gcc/ada/a-dirval.adb index c3da2efd437..7a08500a232 100644 --- a/main/gcc/ada/a-dirval.adb +++ b/main/gcc/ada/a-dirval.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (POSIX Version) -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,15 +93,6 @@ package body Ada.Directories.Validity is end Is_Valid_Simple_Name; ------------- - -- OpenVMS -- - ------------- - - function OpenVMS return Boolean is - begin - return False; - end OpenVMS; - - ------------- -- Windows -- ------------- diff --git a/main/gcc/ada/a-dirval.ads b/main/gcc/ada/a-dirval.ads index f7b2bb6728c..9505dffd6fa 100644 --- a/main/gcc/ada/a-dirval.ads +++ b/main/gcc/ada/a-dirval.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 +43,6 @@ private package Ada.Directories.Validity is function Is_Path_Name_Case_Sensitive return Boolean; -- Returns True if file and path names are case-sensitive - function OpenVMS return Boolean; - -- Return True when OS is OpenVMS - function Windows return Boolean; -- Return True when OS is Windows diff --git a/main/gcc/ada/a-elchha.adb b/main/gcc/ada/a-elchha.adb index f029c3bd2d2..6ef2e0339f2 100644 --- a/main/gcc/ada/a-elchha.adb +++ b/main/gcc/ada/a-elchha.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -49,14 +49,19 @@ is pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); procedure Append_Info_Exception_Message - (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); pragma Import (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); - procedure Append_Info_Exception_Information - (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); + procedure Append_Info_Untailored_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); pragma Import - (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info"); + (Ada, Append_Info_Untailored_Exception_Information, + "__gnat_append_info_u_e_info"); procedure To_Stderr (S : String); pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); @@ -129,7 +134,7 @@ begin To_Stderr ("Execution terminated by unhandled exception"); To_Stderr (Nline); - Append_Info_Exception_Information (Except, Nobuf, Ptr); + Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr); end if; Unhandled_Terminate; diff --git a/main/gcc/ada/a-excach.adb b/main/gcc/ada/a-excach.adb index ab82920519d..b1cc22b94bf 100644 --- a/main/gcc/ada/a-excach.adb +++ b/main/gcc/ada/a-excach.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -63,7 +63,7 @@ begin -- outside the AAA/ZZZ range. System.Traceback.Call_Chain - (Traceback => Excep.Tracebacks'Address, + (Traceback => Excep.Tracebacks, Max_Len => Max_Tracebacks, Len => Excep.Num_Tracebacks, Exclude_Min => Code_Address_For_AAA, diff --git a/main/gcc/ada/a-except-2005.adb b/main/gcc/ada/a-except-2005.adb index 7ed9e0302bd..0b33c0c9f3f 100644 --- a/main/gcc/ada/a-except-2005.adb +++ b/main/gcc/ada/a-except-2005.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,14 +74,14 @@ package body Ada.Exceptions is -- These procedures are used to provide exclusion bounds in -- calls to Call_Chain at exception raise points from this unit. The -- purpose is to arrange for the exception tracebacks not to include - -- frames from routines involved in the raise process, as these are + -- frames from subprograms involved in the raise process, as these are -- meaningless from the user's standpoint. -- -- For these bounds to be meaningful, we need to ensure that the object - -- code for the routines involved in processing a raise is located after - -- the object code Code_Address_For_AAA and before the object code - -- Code_Address_For_ZZZ. This will indeed be the case as long as the - -- following rules are respected: + -- code for the subprograms involved in processing a raise is located + -- after the object code Code_Address_For_AAA and before the object + -- code Code_Address_For_ZZZ. This will indeed be the case as long as + -- the following rules are respected: -- -- 1) The bodies of the subprograms involved in processing a raise -- are located after the body of Code_Address_For_AAA and before the @@ -111,9 +111,9 @@ package body Ada.Exceptions is package Exception_Data is - --------------------------------- - -- Exception messages routines -- - --------------------------------- + ----------------------------------- + -- Exception Message Subprograms -- + ----------------------------------- procedure Set_Exception_C_Msg (Excep : EOA; @@ -138,12 +138,17 @@ package body Ada.Exceptions is -- to contain the indicated Id value and message. Message is a string -- which is generated as the exception message. - -------------------------------------- - -- Exception information subprogram -- - -------------------------------------- + --------------------------------------- + -- Exception Information Subprograms -- + --------------------------------------- - function Exception_Information (X : Exception_Occurrence) return String; - -- The format of the exception information is as follows: + function Untailored_Exception_Information + (X : Exception_Occurrence) return String; + -- This is used by Stream_Attributes.EO_To_String to convert an + -- Exception_Occurrence to a String for the stream attributes. + -- String_To_EO understands the format, as documented here. + -- + -- The format of the string is as follows: -- -- Exception_Name: (as in Exception_Name) -- Message: (only if Exception_Message is empty) @@ -154,54 +159,35 @@ package body Ada.Exceptions is -- The lines are separated by a ASCII.LF character. -- The nnnn is the partition Id given as decimal digits. -- The 0x... line represents traceback program counter locations, in - -- execution order with the first one being the exception location. It - -- is present only + -- execution order with the first one being the exception location. -- -- The Exception_Name and Message lines are omitted in the abort -- signal case, since this is not really an exception. - + -- -- Note: If the format of the generated string is changed, please note -- that an equivalent modification to the routine String_To_EO must be -- made to preserve proper functioning of the stream attributes. - --------------------------------------- - -- Exception backtracing subprograms -- - --------------------------------------- - - -- What is automatically output when exception tracing is on is the - -- usual exception information with the call chain backtrace possibly - -- tailored by a backtrace decorator. Modifying Exception_Information - -- itself is not a good idea because the decorated output is completely - -- out of control and would break all our code related to the streaming - -- of exceptions. We then provide an alternative function to compute - -- the possibly tailored output, which is equivalent if no decorator is - -- currently set: - - function Tailored_Exception_Information - (X : Exception_Occurrence) return String; - -- Exception information to be output in the case of automatic tracing - -- requested through GNAT.Exception_Traces. + function Exception_Information (X : Exception_Occurrence) return String; + -- This is the implementation of Ada.Exceptions.Exception_Information, + -- as defined in the Ada RM. -- - -- This is the same as Exception_Information if no backtrace decorator - -- is currently in place. Otherwise, this is Exception_Information with - -- the call chain raw addresses replaced by the result of a call to the - -- current decorator provided with the call chain addresses. - - pragma Export - (Ada, Tailored_Exception_Information, - "__gnat_tailored_exception_information"); - -- This is currently used by System.Tasking.Stages + -- If no traceback decorator (see GNAT.Exception_Traces) is currently + -- in place, this is the same as Untailored_Exception_Information. + -- Otherwise, the decorator is used to produce a symbolic traceback + -- instead of hexadecimal addresses. + -- + -- Note that unlike Untailored_Exception_Information, there is no need + -- to keep the output of Exception_Information stable for streaming + -- purposes, and in fact the output differs across platforms. end Exception_Data; package Exception_Traces is - use Exception_Data; - -- Imports Tailored_Exception_Information - - ---------------------------------------------- - -- Run-Time Exception Notification Routines -- - ---------------------------------------------- + ------------------------------------------------- + -- Run-Time Exception Notification Subprograms -- + ------------------------------------------------- -- These subprograms provide a common run-time interface to trigger the -- actions required when an exception is about to be propagated (e.g. @@ -233,9 +219,9 @@ package body Ada.Exceptions is package Exception_Propagation is - ------------------------------------ - -- Exception propagation routines -- - ------------------------------------ + --------------------------------------- + -- Exception Propagation Subprograms -- + --------------------------------------- function Allocate_Occurrence return EOA; -- Allocate an exception occurence (as well as the machine occurence) @@ -248,9 +234,9 @@ package body Ada.Exceptions is package Stream_Attributes is - -------------------------------- - -- Stream attributes routines -- - -------------------------------- + ---------------------------------- + -- Stream Attribute Subprograms -- + ---------------------------------- function EId_To_String (X : Exception_Id) return String; function String_To_EId (S : String) return Exception_Id; @@ -396,11 +382,11 @@ package body Ada.Exceptions is -- Source as an exception to be propagated in the caller task. Target is -- expected to be a pointer to the fixed TSD occurrence for this task. - ----------------------------- - -- Run-Time Check Routines -- - ----------------------------- + -------------------------------- + -- Run-Time Check Subprograms -- + -------------------------------- - -- These routines raise a specific exception with a reason message + -- These subprograms raise a specific exception with a reason message -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. @@ -456,6 +442,8 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_PE_Missing_Return (File : System.Address; Line : Integer); + procedure Rcheck_PE_Non_Transportable_Actual + (File : System.Address; Line : Integer); procedure Rcheck_PE_Overlaid_Controlled_Object (File : System.Address; Line : Integer); procedure Rcheck_PE_Potentially_Blocking_Operation @@ -464,8 +452,6 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_PE_Unchecked_Union_Restriction (File : System.Address; Line : Integer); - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer); procedure Rcheck_SE_Empty_Storage_Pool (File : System.Address; Line : Integer); procedure Rcheck_SE_Explicit_Raise @@ -474,7 +460,8 @@ package body Ada.Exceptions is (File : System.Address; Line : Integer); procedure Rcheck_SE_Object_Too_Large (File : System.Address; Line : Integer); - + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer); procedure Rcheck_CE_Access_Check_Ext (File : System.Address; Line, Column : Integer); procedure Rcheck_CE_Index_Check_Ext @@ -489,7 +476,7 @@ package body Ada.Exceptions is -- This routine is separated out because it has quite different behavior -- from the others. This is the "finalize/adjust raised exception". This -- subprogram is always called with abort deferred, unlike all other - -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer. + -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. pragma Export (C, Rcheck_CE_Access_Check, "__gnat_rcheck_CE_Access_Check"); @@ -545,16 +532,18 @@ package body Ada.Exceptions is "__gnat_rcheck_PE_Misaligned_Address_Value"); pragma Export (C, Rcheck_PE_Missing_Return, "__gnat_rcheck_PE_Missing_Return"); + pragma Export (C, Rcheck_PE_Non_Transportable_Actual, + "__gnat_rcheck_PE_Non_Transportable_Actual"); pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, "__gnat_rcheck_PE_Overlaid_Controlled_Object"); pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, "__gnat_rcheck_PE_Potentially_Blocking_Operation"); + pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, + "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, "__gnat_rcheck_PE_Unchecked_Union_Restriction"); - pragma Export (C, Rcheck_PE_Non_Transportable_Actual, - "__gnat_rcheck_PE_Non_Transportable_Actual"); pragma Export (C, Rcheck_SE_Empty_Storage_Pool, "__gnat_rcheck_SE_Empty_Storage_Pool"); pragma Export (C, Rcheck_SE_Explicit_Raise, @@ -603,11 +592,12 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_PE_Implicit_Return); pragma No_Return (Rcheck_PE_Misaligned_Address_Value); pragma No_Return (Rcheck_PE_Missing_Return); + pragma No_Return (Rcheck_PE_Non_Transportable_Actual); pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); + pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); - pragma No_Return (Rcheck_PE_Non_Transportable_Actual); pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); pragma No_Return (Rcheck_SE_Empty_Storage_Pool); pragma No_Return (Rcheck_SE_Explicit_Raise); @@ -668,6 +658,7 @@ package body Ada.Exceptions is Rmsg_33 : constant String := "explicit raise" & NUL; Rmsg_34 : constant String := "infinite recursion" & NUL; Rmsg_35 : constant String := "object too large" & NUL; + Rmsg_36 : constant String := "stream operation not allowed" & NUL; ----------------------- -- Polling Interface -- @@ -681,24 +672,23 @@ package body Ada.Exceptions is -- perform periodic but not systematic operations. procedure Poll is separate; - -- The actual polling routine is separate, so that it can easily - -- be replaced with a target dependent version. + -- The actual polling routine is separate, so that it can easily be + -- replaced with a target dependent version. -------------------------- -- Code_Address_For_AAA -- -------------------------- - -- This function gives us the start of the PC range for addresses - -- within the exception unit itself. We hope that gigi/gcc keep all the - -- procedures in their original order. + -- This function gives us the start of the PC range for addresses within + -- the exception unit itself. We hope that gigi/gcc keep all the procedures + -- in their original order. function Code_Address_For_AAA return System.Address is begin - -- We are using a label instead of merely using - -- Code_Address_For_AAA'Address because on some platforms the latter - -- does not yield the address we want, but the address of a stub or of - -- a descriptor instead. This is the case at least on Alpha-VMS and - -- PA-HPUX. + -- We are using a label instead of Code_Address_For_AAA'Address because + -- on some platforms the latter does not yield the address we want, but + -- the address of a stub or of a descriptor instead. This is the case at + -- least on PA-HPUX. <> return Start_Of_AAA'Address; @@ -732,8 +722,8 @@ package body Ada.Exceptions is -- EO_To_String -- ------------------ - -- We use the null string to represent the null occurrence, otherwise - -- we output the Exception_Information string for the occurrence. + -- We use the null string to represent the null occurrence, otherwise we + -- output the Untailored_Exception_Information string for the occurrence. function EO_To_String (X : Exception_Occurrence) return String renames Stream_Attributes.EO_To_String; @@ -1206,9 +1196,9 @@ package body Ada.Exceptions is Complete_And_Propagate_Occurrence (Excep); end Raise_With_Msg; - -------------------------------------- - -- Calls to Run-Time Check Routines -- - -------------------------------------- + ----------------------------------------- + -- Calls to Run-Time Check Subprograms -- + ----------------------------------------- procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer) @@ -1392,6 +1382,13 @@ package body Ada.Exceptions is Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); end Rcheck_PE_Missing_Return; + procedure Rcheck_PE_Non_Transportable_Actual + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); + end Rcheck_PE_Non_Transportable_Actual; + procedure Rcheck_PE_Overlaid_Controlled_Object (File : System.Address; Line : Integer) is @@ -1406,6 +1403,13 @@ package body Ada.Exceptions is Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); end Rcheck_PE_Potentially_Blocking_Operation; + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); + end Rcheck_PE_Stream_Operation_Not_Allowed; + procedure Rcheck_PE_Stubbed_Subprogram_Called (File : System.Address; Line : Integer) is @@ -1420,13 +1424,6 @@ package body Ada.Exceptions is Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); end Rcheck_PE_Unchecked_Union_Restriction; - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); - end Rcheck_PE_Non_Transportable_Actual; - procedure Rcheck_SE_Empty_Storage_Pool (File : System.Address; Line : Integer) is @@ -1466,9 +1463,9 @@ package body Ada.Exceptions is (File : System.Address; Line, Column, Index, First, Last : Integer) is Msg : constant String := - Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF & - "index " & Image (Index) & " not in " & Image (First) & - ".." & Image (Last) & ASCII.NUL; + Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF + & "index " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; begin Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_CE_Index_Check_Ext; @@ -1477,9 +1474,9 @@ package body Ada.Exceptions is (File : System.Address; Line, Column, Index, First, Last : Integer) is Msg : constant String := - Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF & - "value " & Image (Index) & " not in " & Image (First) & - ".." & Image (Last) & ASCII.NUL; + Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; begin Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_CE_Invalid_Data_Ext; @@ -1488,9 +1485,9 @@ package body Ada.Exceptions is (File : System.Address; Line, Column, Index, First, Last : Integer) is Msg : constant String := - Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF & - "value " & Image (Index) & " not in " & Image (First) & - ".." & Image (Last) & ASCII.NUL; + Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; begin Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); end Rcheck_CE_Range_Check_Ext; @@ -1502,7 +1499,7 @@ package body Ada.Exceptions is begin -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* routines, it + -- called with abort deferred, unlike all other Rcheck_* subprograms, it -- needs to call Raise_Exception_No_Defer. -- This is consistent with Raise_From_Controlled_Operation diff --git a/main/gcc/ada/a-except-2005.ads b/main/gcc/ada/a-except-2005.ads index 90c952c3086..7bf20dc32f3 100644 --- a/main/gcc/ada/a-except-2005.ads +++ b/main/gcc/ada/a-except-2005.ads @@ -291,7 +291,7 @@ private Max_Tracebacks : constant := 50; -- Maximum number of trace backs stored in exception occurrence - type Tracebacks_Array is array (1 .. Max_Tracebacks) of TBE.Traceback_Entry; + subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks); -- Traceback array stored in exception occurrence type Exception_Occurrence is record diff --git a/main/gcc/ada/a-except.adb b/main/gcc/ada/a-except.adb index 9e4b1e8e4ce..a436d6fb725 100644 --- a/main/gcc/ada/a-except.adb +++ b/main/gcc/ada/a-except.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -88,9 +88,9 @@ package body Ada.Exceptions is package Exception_Data is - --------------------------------- - -- Exception messages routines -- - --------------------------------- + ----------------------------------- + -- Exception Message Subprograms -- + ----------------------------------- procedure Set_Exception_C_Msg (Excep : EOA; @@ -116,12 +116,17 @@ package body Ada.Exceptions is -- message. Message is a string which is generated as the exception -- message. - -------------------------------------- - -- Exception information subprogram -- - -------------------------------------- + --------------------------------------- + -- Exception Information Subprograms -- + --------------------------------------- - function Exception_Information (X : Exception_Occurrence) return String; - -- The format of the exception information is as follows: + function Untailored_Exception_Information + (X : Exception_Occurrence) return String; + -- This is used by Stream_Attributes.EO_To_String to convert an + -- Exception_Occurrence to a String for the stream attributes. + -- String_To_EO understands the format, as documented here. + -- + -- The format of the string is as follows: -- -- Exception_Name: (as in Exception_Name) -- Message: (only if Exception_Message is empty) @@ -129,59 +134,38 @@ package body Ada.Exceptions is -- Call stack traceback locations: (only if at least one location) -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) -- - -- The lines are separated by a ASCII.LF character - -- - -- The nnnn is the partition Id given as decimal digits - -- + -- The lines are separated by a ASCII.LF character. + -- The nnnn is the partition Id given as decimal digits. -- The 0x... line represents traceback program counter locations, in - -- execution order with the first one being the exception location. It - -- is present only + -- execution order with the first one being the exception location. + -- + -- The Exception_Name and Message lines are omitted in the abort + -- signal case, since this is not really an exception. -- - -- The Exception_Name and Message lines are omitted in the abort signal - -- case, since this is not really an exception. - -- Note: If the format of the generated string is changed, please note -- that an equivalent modification to the routine String_To_EO must be -- made to preserve proper functioning of the stream attributes. - --------------------------------------- - -- Exception backtracing subprograms -- - --------------------------------------- - - -- What is automatically output when exception tracing is on is the - -- usual exception information with the call chain backtrace possibly - -- tailored by a backtrace decorator. Modifying Exception_Information - -- itself is not a good idea because the decorated output is completely - -- out of control and would break all our code related to the streaming - -- of exceptions. We then provide an alternative function to compute - -- the possibly tailored output, which is equivalent if no decorator is - -- currently set: - - function Tailored_Exception_Information - (X : Exception_Occurrence) return String; - -- Exception information to be output in the case of automatic tracing - -- requested through GNAT.Exception_Traces. + function Exception_Information (X : Exception_Occurrence) return String; + -- This is the implementation of Ada.Exceptions.Exception_Information, + -- as defined in the Ada RM. -- - -- This is the same as Exception_Information if no backtrace decorator - -- is currently in place. Otherwise, this is Exception_Information with - -- the call chain raw addresses replaced by the result of a call to the - -- current decorator provided with the call chain addresses. - - pragma Export - (Ada, Tailored_Exception_Information, - "__gnat_tailored_exception_information"); - -- This is currently used by System.Tasking.Stages + -- If no traceback decorator (see GNAT.Exception_Traces) is currently + -- in place, this is the same as Untailored_Exception_Information. + -- Otherwise, the decorator is used to produce a symbolic traceback + -- instead of hexadecimal addresses. + -- + -- Note that unlike Untailored_Exception_Information, there is no need + -- to keep the output of Exception_Information stable for streaming + -- purposes, and in fact the output differs across platforms. end Exception_Data; package Exception_Traces is - use Exception_Data; - -- Imports Tailored_Exception_Information - - ---------------------------------------------- - -- Run-Time Exception Notification Routines -- - ---------------------------------------------- + ------------------------------------------------- + -- Run-Time Exception Notification Subprograms -- + ------------------------------------------------- -- These subprograms provide a common run-time interface to trigger the -- actions required when an exception is about to be propagated (e.g. @@ -213,9 +197,9 @@ package body Ada.Exceptions is package Stream_Attributes is - -------------------------------- - -- Stream attributes routines -- - -------------------------------- + ---------------------------------- + -- Stream Attribute Subprograms -- + ---------------------------------- function EId_To_String (X : Exception_Id) return String; function String_To_EId (S : String) return Exception_Id; @@ -238,7 +222,8 @@ package body Ada.Exceptions is -- about it. procedure Raise_Exception_No_Defer - (E : Exception_Id; Message : String := ""); + (E : Exception_Id; + Message : String := ""); pragma Export (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); @@ -352,91 +337,104 @@ package body Ada.Exceptions is -- caller task. Target is expected to be a pointer to the fixed TSD -- occurrence for this task. - ----------------------------- - -- Run-Time Check Routines -- - ----------------------------- + -------------------------------- + -- Run-Time Check Subprograms -- + -------------------------------- - -- These routines raise a specific exception with a reason message + -- These subprograms raise a specific exception with a reason message -- attached. The parameters are the file name and line number in each -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. - procedure Rcheck_CE_Access_Check + -- Note on ordering of these subprograms. Normally in the Ada.Exceptions + -- units we do not care about the ordering of entries for Rcheck + -- subprograms, and the normal approach is to keep them in the same + -- order as declarations in Types. + + -- This section is an IMPORTANT EXCEPTION. It is required by the .Net + -- runtime that the routine Rcheck_PE_Finalize_Raise_Exception is at the + -- end of the list (for reasons that are documented in the exceptmsg.awk + -- script which takes care of generating the required exception data). + + procedure Rcheck_CE_Access_Check -- 00 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Access_Parameter + procedure Rcheck_CE_Null_Access_Parameter -- 01 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Discriminant_Check + procedure Rcheck_CE_Discriminant_Check -- 02 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Divide_By_Zero + procedure Rcheck_CE_Divide_By_Zero -- 03 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Explicit_Raise + procedure Rcheck_CE_Explicit_Raise -- 04 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Index_Check + procedure Rcheck_CE_Index_Check -- 05 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Invalid_Data + procedure Rcheck_CE_Invalid_Data -- 06 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Length_Check + procedure Rcheck_CE_Length_Check -- 07 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Exception_Id + procedure Rcheck_CE_Null_Exception_Id -- 08 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Not_Allowed + procedure Rcheck_CE_Null_Not_Allowed -- 09 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Overflow_Check + procedure Rcheck_CE_Overflow_Check -- 10 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Partition_Check + procedure Rcheck_CE_Partition_Check -- 11 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Range_Check + procedure Rcheck_CE_Range_Check -- 12 (File : System.Address; Line : Integer); - procedure Rcheck_CE_Tag_Check + procedure Rcheck_CE_Tag_Check -- 13 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Access_Before_Elaboration + procedure Rcheck_PE_Access_Before_Elaboration -- 14 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Accessibility_Check + procedure Rcheck_PE_Accessibility_Check -- 15 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Address_Of_Intrinsic + procedure Rcheck_PE_Address_Of_Intrinsic -- 16 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Aliased_Parameters + procedure Rcheck_PE_Aliased_Parameters -- 17 (File : System.Address; Line : Integer); - procedure Rcheck_PE_All_Guards_Closed + procedure Rcheck_PE_All_Guards_Closed -- 18 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Bad_Predicated_Generic_Type + procedure Rcheck_PE_Bad_Predicated_Generic_Type -- 19 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Current_Task_In_Entry_Body + procedure Rcheck_PE_Current_Task_In_Entry_Body -- 20 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Duplicated_Entry_Address + procedure Rcheck_PE_Duplicated_Entry_Address -- 21 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Explicit_Raise + procedure Rcheck_PE_Explicit_Raise -- 22 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Implicit_Return + + procedure Rcheck_PE_Implicit_Return -- 24 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Misaligned_Address_Value + procedure Rcheck_PE_Misaligned_Address_Value -- 25 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Missing_Return + procedure Rcheck_PE_Missing_Return -- 26 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Overlaid_Controlled_Object + procedure Rcheck_PE_Overlaid_Controlled_Object -- 27 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Potentially_Blocking_Operation + procedure Rcheck_PE_Potentially_Blocking_Operation -- 28 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stubbed_Subprogram_Called + procedure Rcheck_PE_Stubbed_Subprogram_Called -- 29 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Unchecked_Union_Restriction + procedure Rcheck_PE_Unchecked_Union_Restriction -- 30 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Non_Transportable_Actual + procedure Rcheck_PE_Non_Transportable_Actual -- 31 (File : System.Address; Line : Integer); - procedure Rcheck_SE_Empty_Storage_Pool + procedure Rcheck_SE_Empty_Storage_Pool -- 32 (File : System.Address; Line : Integer); - procedure Rcheck_SE_Explicit_Raise + procedure Rcheck_SE_Explicit_Raise -- 33 (File : System.Address; Line : Integer); - procedure Rcheck_SE_Infinite_Recursion + procedure Rcheck_SE_Infinite_Recursion -- 34 (File : System.Address; Line : Integer); - procedure Rcheck_SE_Object_Too_Large + procedure Rcheck_SE_Object_Too_Large -- 35 + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Stream_Operation_Not_Allowed -- 36 (File : System.Address; Line : Integer); - procedure Rcheck_PE_Finalize_Raised_Exception + procedure Rcheck_PE_Finalize_Raised_Exception -- 23 (File : System.Address; Line : Integer); -- This routine is separated out because it has quite different behavior -- from the others. This is the "finalize/adjust raised exception". This -- subprogram is always called with abort deferred, unlike all other - -- Rcheck_* routines, it needs to call Raise_Exception_No_Defer. + -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. pragma Export (C, Rcheck_CE_Access_Check, "__gnat_rcheck_CE_Access_Check"); @@ -492,16 +490,18 @@ package body Ada.Exceptions is "__gnat_rcheck_PE_Misaligned_Address_Value"); pragma Export (C, Rcheck_PE_Missing_Return, "__gnat_rcheck_PE_Missing_Return"); + pragma Export (C, Rcheck_PE_Non_Transportable_Actual, + "__gnat_rcheck_PE_Non_Transportable_Actual"); pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, "__gnat_rcheck_PE_Overlaid_Controlled_Object"); pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, "__gnat_rcheck_PE_Potentially_Blocking_Operation"); + pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, + "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, "__gnat_rcheck_PE_Unchecked_Union_Restriction"); - pragma Export (C, Rcheck_PE_Non_Transportable_Actual, - "__gnat_rcheck_PE_Non_Transportable_Actual"); pragma Export (C, Rcheck_SE_Empty_Storage_Pool, "__gnat_rcheck_SE_Empty_Storage_Pool"); pragma Export (C, Rcheck_SE_Explicit_Raise, @@ -542,10 +542,11 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_PE_Misaligned_Address_Value); pragma No_Return (Rcheck_PE_Missing_Return); pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); + pragma No_Return (Rcheck_PE_Non_Transportable_Actual); pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); + pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); - pragma No_Return (Rcheck_PE_Non_Transportable_Actual); pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); pragma No_Return (Rcheck_SE_Empty_Storage_Pool); pragma No_Return (Rcheck_SE_Explicit_Raise); @@ -576,6 +577,7 @@ package body Ada.Exceptions is procedure Rcheck_19 (File : System.Address; Line : Integer); procedure Rcheck_20 (File : System.Address; Line : Integer); procedure Rcheck_21 (File : System.Address; Line : Integer); + procedure Rcheck_22 (File : System.Address; Line : Integer); procedure Rcheck_23 (File : System.Address; Line : Integer); procedure Rcheck_24 (File : System.Address; Line : Integer); procedure Rcheck_25 (File : System.Address; Line : Integer); @@ -589,8 +591,7 @@ package body Ada.Exceptions is procedure Rcheck_33 (File : System.Address; Line : Integer); procedure Rcheck_34 (File : System.Address; Line : Integer); procedure Rcheck_35 (File : System.Address; Line : Integer); - - procedure Rcheck_22 (File : System.Address; Line : Integer); + procedure Rcheck_36 (File : System.Address; Line : Integer); pragma Export (C, Rcheck_00, "__gnat_rcheck_00"); pragma Export (C, Rcheck_01, "__gnat_rcheck_01"); @@ -628,6 +629,7 @@ package body Ada.Exceptions is pragma Export (C, Rcheck_33, "__gnat_rcheck_33"); pragma Export (C, Rcheck_34, "__gnat_rcheck_34"); pragma Export (C, Rcheck_35, "__gnat_rcheck_35"); + pragma Export (C, Rcheck_36, "__gnat_rcheck_36"); -- None of these procedures ever returns (they raise an exception). By -- using pragma No_Return, we ensure that any junk code after the call, @@ -668,6 +670,7 @@ package body Ada.Exceptions is pragma No_Return (Rcheck_33); pragma No_Return (Rcheck_34); pragma No_Return (Rcheck_35); + pragma No_Return (Rcheck_36); --------------------------------------------- -- Reason Strings for Run-Time Check Calls -- @@ -718,6 +721,7 @@ package body Ada.Exceptions is Rmsg_33 : constant String := "explicit raise" & NUL; Rmsg_34 : constant String := "infinite recursion" & NUL; Rmsg_35 : constant String := "object too large" & NUL; + Rmsg_36 : constant String := "stream operation not allowed" & NUL; ----------------------- -- Polling Interface -- @@ -755,7 +759,7 @@ package body Ada.Exceptions is ------------------ -- We use the null string to represent the null occurrence, otherwise we - -- output the Exception_Information string for the occurrence. + -- output the Untailored_Exception_Information string for the occurrence. function EO_To_String (X : Exception_Occurrence) return String renames Stream_Attributes.EO_To_String; @@ -787,9 +791,9 @@ package body Ada.Exceptions is begin if X.Id = Null_Id then raise Constraint_Error; + else + return Exception_Data.Exception_Information (X); end if; - - return Exception_Data.Exception_Information (X); end Exception_Information; ----------------------- @@ -1171,9 +1175,9 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_With_Msg; - -------------------------------------- - -- Calls to Run-Time Check Routines -- - -------------------------------------- + ----------------------------------------- + -- Calls to Run-Time Check Subprograms -- + ----------------------------------------- procedure Rcheck_CE_Access_Check (File : System.Address; Line : Integer) @@ -1420,15 +1424,23 @@ package body Ada.Exceptions is Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address); end Rcheck_SE_Object_Too_Large; + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); + end Rcheck_PE_Stream_Operation_Not_Allowed; + procedure Rcheck_PE_Finalize_Raised_Exception (File : System.Address; Line : Integer) is E : constant Exception_Id := Program_Error_Def'Access; Excep : constant EOA := Get_Current_Excep.all; + begin -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* routines, it - -- needs to call Raise_Exception_No_Defer. + -- called with abort deferred, unlike all other Rcheck_* subprograms, + -- itneeds to call Raise_Exception_No_Defer. -- This is consistent with Raise_From_Controlled_Operation @@ -1483,6 +1495,8 @@ package body Ada.Exceptions is renames Rcheck_PE_Duplicated_Entry_Address; procedure Rcheck_22 (File : System.Address; Line : Integer) renames Rcheck_PE_Explicit_Raise; + procedure Rcheck_23 (File : System.Address; Line : Integer) + renames Rcheck_PE_Finalize_Raised_Exception; procedure Rcheck_24 (File : System.Address; Line : Integer) renames Rcheck_PE_Implicit_Return; procedure Rcheck_25 (File : System.Address; Line : Integer) @@ -1507,9 +1521,8 @@ package body Ada.Exceptions is renames Rcheck_SE_Infinite_Recursion; procedure Rcheck_35 (File : System.Address; Line : Integer) renames Rcheck_SE_Object_Too_Large; - - procedure Rcheck_23 (File : System.Address; Line : Integer) - renames Rcheck_PE_Finalize_Raised_Exception; + procedure Rcheck_36 (File : System.Address; Line : Integer) + renames Rcheck_PE_Stream_Operation_Not_Allowed; ------------- -- Reraise -- diff --git a/main/gcc/ada/a-except.ads b/main/gcc/ada/a-except.ads index 1228bf5fae5..183bd58ba37 100644 --- a/main/gcc/ada/a-except.ads +++ b/main/gcc/ada/a-except.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- @@ -265,7 +265,7 @@ private Max_Tracebacks : constant := 50; -- Maximum number of trace backs stored in exception occurrence - type Tracebacks_Array is array (1 .. Max_Tracebacks) of TBE.Traceback_Entry; + subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks); -- Traceback array stored in exception occurrence type Exception_Occurrence is record diff --git a/main/gcc/ada/a-excpol-abort.adb b/main/gcc/ada/a-excpol-abort.adb index ebfc1a0b4d4..d4f9a078657 100644 --- a/main/gcc/ada/a-excpol-abort.adb +++ b/main/gcc/ada/a-excpol-abort.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -35,7 +35,7 @@ -- that activates periodic polling. Then in the body of the polling routine -- we test for asynchronous abort. --- Windows, HPUX 10 and VMS currently use this file +-- Windows and HPUX 10 currently use this file pragma Warnings (Off); -- Allow withing of non-Preelaborated units in Ada 2005 mode where this diff --git a/main/gcc/ada/a-exctra.ads b/main/gcc/ada/a-exctra.ads index 6d22c1c746b..664bd75221f 100644 --- a/main/gcc/ada/a-exctra.ads +++ b/main/gcc/ada/a-exctra.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, 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,7 @@ package Ada.Exceptions.Traceback is subtype Code_Loc is System.Address; -- Code location in executing program - type Tracebacks_Array is array (Positive range <>) of STBE.Traceback_Entry; + subtype Tracebacks_Array is STBE.Tracebacks_Array; -- A traceback array is an array of traceback entries function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array; @@ -52,6 +52,9 @@ package Ada.Exceptions.Traceback is -- occurrence, and returns it formatted in the manner required for -- processing in GNAT.Traceback. See g-traceb.ads for further details. + function "=" (A, B : Tracebacks_Array) return Boolean renames STBE."="; + -- Make "=" operator visible directly + function Get_PC (TBE : STBE.Traceback_Entry) return Code_Loc renames STBE.PC_For; -- Returns the code address held by a given traceback entry, typically the diff --git a/main/gcc/ada/a-exexda.adb b/main/gcc/ada/a-exexda.adb index a201551b702..ec45c02e035 100644 --- a/main/gcc/ada/a-exexda.adb +++ b/main/gcc/ada/a-exexda.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,39 +36,40 @@ package body Exception_Data is -- This unit implements the Exception_Information related services for -- both the Ada standard requirements and the GNAT.Exception_Traces - -- facility. + -- facility. This is also used by the implementation of the stream + -- attributes of types Exception_Id and Exception_Occurrence. -- There are common parts between the contents of Exception_Information - -- (the regular Ada interface) and Tailored_Exception_Information (what - -- the automatic backtracing output includes). The overall structure is - -- sketched below: + -- (the regular Ada interface) and Untailored_Exception_Information (used + -- for streaming, and when there is no symbolic traceback available) The + -- overall structure is sketched below: -- - -- Exception_Information + -- Untailored_Exception_Information -- | -- +-------+--------+ -- | | - -- Basic_Exc_Info & Basic_Exc_Tback - -- (B_E_I) (B_E_TB) + -- Basic_Exc_Info & Untailored_Exc_Tback + -- (B_E_I) (U_E_TB) -- o-- -- (B_E_I) | Exception_Name: (as in Exception_Name) -- | Message: (or a null line if no message) -- | PID=nnnn (if != 0) -- o-- - -- (B_E_TB) | Call stack traceback locations: + -- (U_E_TB) | Call stack traceback locations: -- | <0xyyyyyyyy 0xyyyyyyyy ...> -- o-- - -- Tailored_Exception_Information + -- Exception_Information -- | -- +----------+----------+ -- | | - -- Basic_Exc_Info & Tailored_Exc_Tback + -- Basic_Exc_Info & traceback -- | -- +-----------+------------+ -- | | - -- Basic_Exc_Tback Or Tback_Decorator + -- Untailored_Exc_Tback Or Tback_Decorator -- if no decorator set otherwise -- Functions returning String imply secondary stack use, which is a heavy @@ -81,8 +82,8 @@ package body Exception_Data is -- The procedural interface is composed of two major sections: a neutral -- section for basic types like Address, Character, Natural or String, and - -- an exception oriented section for the e.g. Basic_Exception_Information. - -- This is the Append_Info family of procedures below. + -- an exception oriented section for the exception names, messages, and + -- information. This is the Append_Info family of procedures below. -- Output to stderr is commanded by passing an empty buffer to update, and -- care is taken not to overflow otherwise. @@ -140,12 +141,12 @@ package body Exception_Data is Info : in out String; Ptr : in out Natural); - procedure Append_Info_Basic_Exception_Traceback + procedure Append_Info_Untailored_Exception_Traceback (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); - procedure Append_Info_Exception_Information + procedure Append_Info_Untailored_Exception_Information (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural); @@ -162,7 +163,7 @@ package body Exception_Data is function Basic_Exception_Info_Maxlength (X : Exception_Occurrence) return Natural; - function Basic_Exception_Tback_Maxlength + function Untailored_Exception_Traceback_Maxlength (X : Exception_Occurrence) return Natural; function Exception_Info_Maxlength @@ -181,11 +182,11 @@ package body Exception_Data is -- Functional Interface -- -------------------------- - function Basic_Exception_Traceback + function Untailored_Exception_Traceback (X : Exception_Occurrence) return String; -- Returns an image of the complete call chain associated with an -- exception occurrence in its most basic form, that is as a raw sequence - -- of hexadecimal binary addresses. + -- of hexadecimal addresses. function Tailored_Exception_Traceback (X : Exception_Occurrence) return String; @@ -201,7 +202,8 @@ package body Exception_Data is (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); pragma Export - (Ada, Append_Info_Exception_Information, "__gnat_append_info_e_info"); + (Ada, Append_Info_Untailored_Exception_Information, + "__gnat_append_info_u_e_info"); pragma Export (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); @@ -242,6 +244,55 @@ package body Exception_Data is Append_Info_String (S (P - 1 .. S'Last), Info, Ptr); end Append_Info_Address; + --------------------------------------------- + -- Append_Info_Basic_Exception_Information -- + --------------------------------------------- + + -- To ease the maximum length computation, we define and pull out a couple + -- of string constants: + + BEI_Name_Header : constant String := "Exception name: "; + BEI_Msg_Header : constant String := "Message: "; + BEI_PID_Header : constant String := "PID: "; + + procedure Append_Info_Basic_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + Name : String (1 .. Exception_Name_Length (X)); + -- Buffer in which to fetch the exception name, in order to check + -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. + + Name_Ptr : Natural := Name'First - 1; + + begin + -- Output exception name and message except for _ABORT_SIGNAL, where + -- these two lines are omitted. + + Append_Info_Exception_Name (X, Name, Name_Ptr); + + if Name (Name'First) /= '_' then + Append_Info_String (BEI_Name_Header, Info, Ptr); + Append_Info_String (Name, Info, Ptr); + Append_Info_NL (Info, Ptr); + + if Exception_Message_Length (X) /= 0 then + Append_Info_String (BEI_Msg_Header, Info, Ptr); + Append_Info_Exception_Message (X, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end if; + + -- Output PID line if non-zero + + if X.Pid /= 0 then + Append_Info_String (BEI_PID_Header, Info, Ptr); + Append_Info_Nat (X.Pid, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end Append_Info_Basic_Exception_Information; + --------------------------- -- Append_Info_Character -- --------------------------- @@ -260,6 +311,72 @@ package body Exception_Data is end if; end Append_Info_Character; + ----------------------------------- + -- Append_Info_Exception_Message -- + ----------------------------------- + + procedure Append_Info_Exception_Message + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + declare + Len : constant Natural := Exception_Message_Length (X); + Msg : constant String (1 .. Len) := X.Msg (1 .. Len); + begin + Append_Info_String (Msg, Info, Ptr); + end; + end Append_Info_Exception_Message; + + -------------------------------- + -- Append_Info_Exception_Name -- + -------------------------------- + + procedure Append_Info_Exception_Name + (Id : Exception_Id; + Info : in out String; + Ptr : in out Natural) + is + begin + if Id = Null_Id then + raise Constraint_Error; + end if; + + declare + Len : constant Natural := Exception_Name_Length (Id); + Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); + begin + Append_Info_String (Name, Info, Ptr); + end; + end Append_Info_Exception_Name; + + procedure Append_Info_Exception_Name + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + Append_Info_Exception_Name (X.Id, Info, Ptr); + end Append_Info_Exception_Name; + + ------------------------------ + -- Exception_Info_Maxlength -- + ------------------------------ + + function Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural + is + begin + return + Basic_Exception_Info_Maxlength (X) + + Untailored_Exception_Traceback_Maxlength (X); + end Exception_Info_Maxlength; + --------------------- -- Append_Info_Nat -- --------------------- @@ -313,78 +430,30 @@ package body Exception_Data is end if; end Append_Info_String; - --------------------------------------------- - -- Append_Info_Basic_Exception_Information -- - --------------------------------------------- - - -- To ease the maximum length computation, we define and pull out a couple - -- of string constants: - - BEI_Name_Header : constant String := "Exception name: "; - BEI_Msg_Header : constant String := "Message: "; - BEI_PID_Header : constant String := "PID: "; + -------------------------------------------------- + -- Append_Info_Untailored_Exception_Information -- + -------------------------------------------------- - procedure Append_Info_Basic_Exception_Information + procedure Append_Info_Untailored_Exception_Information (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural) is - Name : String (1 .. Exception_Name_Length (X)); - -- Buffer in which to fetch the exception name, in order to check - -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. - - Name_Ptr : Natural := Name'First - 1; - - begin - -- Output exception name and message except for _ABORT_SIGNAL, where - -- these two lines are omitted. - - Append_Info_Exception_Name (X, Name, Name_Ptr); - - if Name (Name'First) /= '_' then - Append_Info_String (BEI_Name_Header, Info, Ptr); - Append_Info_String (Name, Info, Ptr); - Append_Info_NL (Info, Ptr); - - if Exception_Message_Length (X) /= 0 then - Append_Info_String (BEI_Msg_Header, Info, Ptr); - Append_Info_Exception_Message (X, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end if; - - -- Output PID line if non-zero - - if X.Pid /= 0 then - Append_Info_String (BEI_PID_Header, Info, Ptr); - Append_Info_Nat (X.Pid, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end Append_Info_Basic_Exception_Information; - - ------------------------------------------- - -- Basic_Exception_Information_Maxlength -- - ------------------------------------------- - - function Basic_Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural is begin - return - BEI_Name_Header'Length + Exception_Name_Length (X) + 1 - + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 - + BEI_PID_Header'Length + 15; - end Basic_Exception_Info_Maxlength; + Append_Info_Basic_Exception_Information (X, Info, Ptr); + Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); + end Append_Info_Untailored_Exception_Information; - ------------------------------------------- - -- Append_Info_Basic_Exception_Traceback -- - ------------------------------------------- + ------------------------------------------------ + -- Append_Info_Untailored_Exception_Traceback -- + ------------------------------------------------ -- As for Basic_Exception_Information: BETB_Header : constant String := "Call stack traceback locations:"; LDAD_Header : constant String := "Load address: "; - procedure Append_Info_Basic_Exception_Traceback + procedure Append_Info_Untailored_Exception_Traceback (X : Exception_Occurrence; Info : in out String; Ptr : in out Natural) @@ -407,6 +476,7 @@ package body Exception_Data is end if; -- The traceback lines + Append_Info_String (BETB_Header, Info, Ptr); Append_Info_NL (Info, Ptr); @@ -417,110 +487,58 @@ package body Exception_Data is end loop; Append_Info_NL (Info, Ptr); - end Append_Info_Basic_Exception_Traceback; + end Append_Info_Untailored_Exception_Traceback; - ----------------------------------------- - -- Basic_Exception_Traceback_Maxlength -- - ----------------------------------------- + ------------------------------------------- + -- Basic_Exception_Information_Maxlength -- + ------------------------------------------- - function Basic_Exception_Tback_Maxlength + function Basic_Exception_Info_Maxlength (X : Exception_Occurrence) return Natural is - Space_Per_Address : constant := 2 + 16 + 1; - -- Space for "0x" + HHHHHHHHHHHHHHHH + " " begin return - LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + - X.Num_Tracebacks * Space_Per_Address + 1; - end Basic_Exception_Tback_Maxlength; + BEI_Name_Header'Length + Exception_Name_Length (X) + 1 + + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 + + BEI_PID_Header'Length + 15; + end Basic_Exception_Info_Maxlength; - --------------------------------------- - -- Append_Info_Exception_Information -- - --------------------------------------- + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information (X : Exception_Occurrence) return String is + -- The tailored exception information is the basic information + -- associated with the tailored call chain backtrace. + + Tback_Info : constant String := Tailored_Exception_Traceback (X); + Tback_Len : constant Natural := Tback_Info'Length; + + Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); + Ptr : Natural := Info'First - 1; - procedure Append_Info_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is begin Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_Basic_Exception_Traceback (X, Info, Ptr); - end Append_Info_Exception_Information; + Append_Info_String (Tback_Info, Info, Ptr); + return Info (Info'First .. Ptr); + end Exception_Information; ------------------------------ - -- Exception_Info_Maxlength -- + -- Exception_Message_Length -- ------------------------------ - function Exception_Info_Maxlength + function Exception_Message_Length (X : Exception_Occurrence) return Natural is begin - return - Basic_Exception_Info_Maxlength (X) - + Basic_Exception_Tback_Maxlength (X); - end Exception_Info_Maxlength; - - ----------------------------------- - -- Append_Info_Exception_Message -- - ----------------------------------- - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - if X.Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Message_Length (X); - Msg : constant String (1 .. Len) := X.Msg (1 .. Len); - begin - Append_Info_String (Msg, Info, Ptr); - end; - end Append_Info_Exception_Message; - - -------------------------------- - -- Append_Info_Exception_Name -- - -------------------------------- - - procedure Append_Info_Exception_Name - (Id : Exception_Id; - Info : in out String; - Ptr : in out Natural) - is - begin - if Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Name_Length (Id); - Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); - begin - Append_Info_String (Name, Info, Ptr); - end; - end Append_Info_Exception_Name; - - procedure Append_Info_Exception_Name - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Exception_Name (X.Id, Info, Ptr); - end Append_Info_Exception_Name; + return X.Msg_Length; + end Exception_Message_Length; --------------------------- -- Exception_Name_Length -- --------------------------- - function Exception_Name_Length - (Id : Exception_Id) return Natural - is + function Exception_Name_Length (Id : Exception_Id) return Natural is begin -- What is stored in the internal Name buffer includes a terminating -- null character that we never care about. @@ -528,50 +546,39 @@ package body Exception_Data is return Id.Name_Length - 1; end Exception_Name_Length; - function Exception_Name_Length - (X : Exception_Occurrence) return Natural is + function Exception_Name_Length (X : Exception_Occurrence) return Natural is begin return Exception_Name_Length (X.Id); end Exception_Name_Length; - ------------------------------ - -- Exception_Message_Length -- - ------------------------------ - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural - is - begin - return X.Msg_Length; - end Exception_Message_Length; - ------------------------------- - -- Basic_Exception_Traceback -- + -- Untailored_Exception_Traceback -- ------------------------------- - function Basic_Exception_Traceback + function Untailored_Exception_Traceback (X : Exception_Occurrence) return String is - Info : aliased String (1 .. Basic_Exception_Tback_Maxlength (X)); + Info : aliased String + (1 .. Untailored_Exception_Traceback_Maxlength (X)); Ptr : Natural := Info'First - 1; begin - Append_Info_Basic_Exception_Traceback (X, Info, Ptr); + Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); return Info (Info'First .. Ptr); - end Basic_Exception_Traceback; + end Untailored_Exception_Traceback; - --------------------------- - -- Exception_Information -- - --------------------------- + -------------------------------------- + -- Untailored_Exception_Information -- + -------------------------------------- - function Exception_Information + function Untailored_Exception_Information (X : Exception_Occurrence) return String is Info : String (1 .. Exception_Info_Maxlength (X)); Ptr : Natural := Info'First - 1; begin - Append_Info_Exception_Information (X, Info, Ptr); + Append_Info_Untailored_Exception_Information (X, Info, Ptr); return Info (Info'First .. Ptr); - end Exception_Information; + end Untailored_Exception_Information; ------------------------- -- Set_Exception_C_Msg -- @@ -678,8 +685,8 @@ package body Exception_Data is Id : Exception_Id; Message : String) is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); + Len : constant Natural := + Natural'Min (Message'Length, Exception_Msg_Max_Length); First : constant Integer := Message'First; begin Excep.Exception_Raised := False; @@ -709,36 +716,29 @@ package body Exception_Data is -- call become inoffensive. Wrapper : constant Traceback_Decorator_Wrapper_Call := - Traceback_Decorator_Wrapper; + Traceback_Decorator_Wrapper; begin if Wrapper = null then - return Basic_Exception_Traceback (X); + return Untailored_Exception_Traceback (X); else return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); end if; end Tailored_Exception_Traceback; - ------------------------------------ - -- Tailored_Exception_Information -- - ------------------------------------ + ---------------------------------------------- + -- Untailored_Exception_Traceback_Maxlength -- + ---------------------------------------------- - function Tailored_Exception_Information - (X : Exception_Occurrence) return String + function Untailored_Exception_Traceback_Maxlength + (X : Exception_Occurrence) return Natural is - -- The tailored exception information is the basic information - -- associated with the tailored call chain backtrace. - - Tback_Info : constant String := Tailored_Exception_Traceback (X); - Tback_Len : constant Natural := Tback_Info'Length; - - Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); - Ptr : Natural := Info'First - 1; - + Space_Per_Address : constant := 2 + 16 + 1; + -- Space for "0x" + HHHHHHHHHHHHHHHH + " " begin - Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); - return Info (Info'First .. Ptr); - end Tailored_Exception_Information; + return + LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + + X.Num_Tracebacks * Space_Per_Address + 1; + end Untailored_Exception_Traceback_Maxlength; end Exception_Data; diff --git a/main/gcc/ada/a-exextr.adb b/main/gcc/ada/a-exextr.adb index fe4b706f7ee..94ec48338f9 100644 --- a/main/gcc/ada/a-exextr.adb +++ b/main/gcc/ada/a-exextr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +99,7 @@ package body Exception_Traces is To_Stderr ("Exception raised"); To_Stderr (Nline); - To_Stderr (Tailored_Exception_Information (Excep.all)); + To_Stderr (Exception_Information (Excep.all)); Unlock_Task.all; end if; diff --git a/main/gcc/ada/a-exstat.adb b/main/gcc/ada/a-exstat.adb index f8f75b2cd13..cd7565f2a64 100644 --- a/main/gcc/ada/a-exstat.adb +++ b/main/gcc/ada/a-exstat.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,15 +59,15 @@ package body Stream_Attributes is -- EO_To_String -- ------------------ - -- We use the null string to represent the null occurrence, otherwise - -- we output the Exception_Information string for the occurrence. + -- We use the null string to represent the null occurrence, otherwise we + -- output the Untailored_Exception_Information string for the occurrence. function EO_To_String (X : Exception_Occurrence) return String is begin if X.Id = Null_Id then return ""; else - return Exception_Information (X); + return Exception_Data.Untailored_Exception_Information (X); end if; end EO_To_String; diff --git a/main/gcc/ada/a-intnam-linux.ads b/main/gcc/ada/a-intnam-linux.ads index 5003c20461a..9bbff6b8323 100644 --- a/main/gcc/ada/a-intnam-linux.ads +++ b/main/gcc/ada/a-intnam-linux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2014, 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- -- @@ -31,12 +31,7 @@ -- This is a GNU/Linux version of this package --- The following signals are reserved by the run time (FSU threads): - --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL - --- The following signals are reserved by the run time (LinuxThreads): +-- The following signals are reserved by the run time: -- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, -- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL diff --git a/main/gcc/ada/a-intnam-vms.ads b/main/gcc/ada/a-intnam-vms.ads deleted file mode 100644 index 30f98d33466..00000000000 --- a/main/gcc/ada/a-intnam-vms.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2011, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; - -package Ada.Interrupts.Names is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - package OS renames System.OS_Interface; - - Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0; - Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1; - Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2; - Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3; - Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4; - Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5; - Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6; - Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7; - Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8; - Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9; - Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10; - Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11; - Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12; - Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13; - Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14; - Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15; - Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16; - Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17; - Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18; - Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19; - Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20; - Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21; - Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22; - Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23; - Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24; - Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25; - Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26; - Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27; - Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28; - Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29; - Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30; - Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31; - -end Ada.Interrupts.Names; diff --git a/main/gcc/ada/a-ngelfu.adb b/main/gcc/ada/a-ngelfu.adb index 796f57415a4..f31f685e795 100644 --- a/main/gcc/ada/a-ngelfu.adb +++ b/main/gcc/ada/a-ngelfu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,12 +509,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is function Cos (X : Float_Type'Base) return Float_Type'Base is begin - if X = 0.0 then - return 1.0; - - elsif abs X < Sqrt_Epsilon then + if abs X < Sqrt_Epsilon then return 1.0; - end if; return Float_Type'Base (Aux.Cos (Double (X))); diff --git a/main/gcc/ada/a-ngelfu.ads b/main/gcc/ada/a-ngelfu.ads index 0d551015711..8afb7332204 100644 --- a/main/gcc/ada/a-ngelfu.ads +++ b/main/gcc/ada/a-ngelfu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2012-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2012-2014, 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 -- @@ -41,8 +41,25 @@ package Ada.Numerics.Generic_Elementary_Functions is function Sqrt (X : Float_Type'Base) return Float_Type'Base with Post => Sqrt'Result >= 0.0 - and then (if X = 0.0 then Sqrt'Result = 0.0) - and then (if X = 1.0 then Sqrt'Result = 1.0); + and then (if X = 0.0 then Sqrt'Result = 0.0) + and then (if X = 1.0 then Sqrt'Result = 1.0) + + -- Finally if X is positive, the result of Sqrt is positive (because + -- the sqrt of numbers greater than 1 is greater than or equal to 1, + -- and the sqrt of numbers less than 1 is greater than the argument). + + -- This property is useful in particular for static analysis. The + -- property that X is positive is not expressed as (X > 0.0), as + -- the value X may be held in registers that have larger range and + -- precision on some architecture (for example, on x86 using x387 + -- FPU, as opposed to SSE2). So, it might be possible for X to be + -- 2.0**(-5000) or so, which could cause the number to compare as + -- greater than 0, but Sqrt would still return a zero result. + + -- Note: we use the comparison with Succ (0.0) here because this is + -- more amenable to CodePeer analysis than the use of 'Machine. + + and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0); function Log (X : Float_Type'Base) return Float_Type'Base with @@ -56,26 +73,26 @@ package Ada.Numerics.Generic_Elementary_Functions is function "**" (Left, Right : Float_Type'Base) return Float_Type'Base with Post => "**"'Result >= 0.0 - and then (if Right = 0.0 then "**"'Result = 1.0) - and then (if Right = 1.0 then "**"'Result = Left) - and then (if Left = 1.0 then "**"'Result = 1.0) - and then (if Left = 0.0 then "**"'Result = 0.0); + and then (if Right = 0.0 then "**"'Result = 1.0) + and then (if Right = 1.0 then "**"'Result = Left) + and then (if Left = 1.0 then "**"'Result = 1.0) + and then (if Left = 0.0 then "**"'Result = 0.0); function Sin (X : Float_Type'Base) return Float_Type'Base with Post => Sin'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Sin'Result = 0.0); + and then (if X = 0.0 then Sin'Result = 0.0); function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base with Post => Sin'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Sin'Result = 0.0); + and then (if X = 0.0 then Sin'Result = 0.0); function Cos (X : Float_Type'Base) return Float_Type'Base with Post => Cos'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Cos'Result = 1.0); + and then (if X = 0.0 then Cos'Result = 1.0); function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base with Post => Cos'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Cos'Result = 1.0); + and then (if X = 0.0 then Cos'Result = 1.0); function Tan (X : Float_Type'Base) return Float_Type'Base with Post => (if X = 0.0 then Tan'Result = 0.0); @@ -130,11 +147,11 @@ package Ada.Numerics.Generic_Elementary_Functions is function Cosh (X : Float_Type'Base) return Float_Type'Base with Post => Cosh'Result >= 1.0 - and then (if X = 0.0 then Cosh'Result = 1.0); + and then (if X = 0.0 then Cosh'Result = 1.0); function Tanh (X : Float_Type'Base) return Float_Type'Base with Post => Tanh'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Tanh'Result = 0.0); + and then (if X = 0.0 then Tanh'Result = 0.0); function Coth (X : Float_Type'Base) return Float_Type'Base with Post => abs Coth'Result >= 1.0; @@ -144,7 +161,7 @@ package Ada.Numerics.Generic_Elementary_Functions is function Arccosh (X : Float_Type'Base) return Float_Type'Base with Post => Arccosh'Result >= 0.0 - and then (if X = 1.0 then Arccosh'Result = 0.0); + and then (if X = 1.0 then Arccosh'Result = 0.0); function Arctanh (X : Float_Type'Base) return Float_Type'Base with Post => (if X = 0.0 then Arctanh'Result = 0.0); diff --git a/main/gcc/ada/a-numaux-darwin.adb b/main/gcc/ada/a-numaux-darwin.adb index 1444603d683..2e9ffd91c11 100644 --- a/main/gcc/ada/a-numaux-darwin.adb +++ b/main/gcc/ada/a-numaux-darwin.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Apple OS X Version) -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 @@ -- -- ------------------------------------------------------------------------------ --- File a-numaux.adb <- a-numaux-darwin.adb - package body Ada.Numerics.Aux is ----------------------- diff --git a/main/gcc/ada/a-numaux-darwin.ads b/main/gcc/ada/a-numaux-darwin.ads index 4164f512d12..011ae592ce4 100644 --- a/main/gcc/ada/a-numaux-darwin.ads +++ b/main/gcc/ada/a-numaux-darwin.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Apple OS X Version) -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 +30,9 @@ -- -- ------------------------------------------------------------------------------ --- This version is for use with normal Unix math functions, except for --- sine/cosine which have been implemented directly in Ada to get --- the required accuracy in OS X. Alternative packages are used --- on OpenVMS (different import names), VxWorks (no need for the --- -lm Linker_Options), and on the x86 (where we have two --- versions one using inline ASM, and one importing from the C long --- routines that take 80-bit arguments). +-- This version is for use on OS X. It uses the normal Unix math functions, +-- except for sine/cosine which have been implemented directly in Ada to get +-- the required accuracy. package Ada.Numerics.Aux is pragma Pure; diff --git a/main/gcc/ada/a-numaux-libc-x86.ads b/main/gcc/ada/a-numaux-libc-x86.ads index 3261c111c43..3b793c6240e 100644 --- a/main/gcc/ada/a-numaux-libc-x86.ads +++ b/main/gcc/ada/a-numaux-libc-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (C Library Version for x86) -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. --- One advantage of using this package is that it will interface directly to --- hardware instructions, such as the those provided on the Intel x86. - --- Note: there are two versions of this package. One using the 80-bit x86 --- long double format (which is this version), and one using 64-bit IEEE --- double (see file a-numaux.ads). +-- This version is for the x86 using the 80-bit x86 long double format package Ada.Numerics.Aux is pragma Pure; diff --git a/main/gcc/ada/a-numaux-vms.ads b/main/gcc/ada/a-numaux-vms.ads deleted file mode 100644 index f6d1dfa9081..00000000000 --- a/main/gcc/ada/a-numaux-vms.ads +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (VMS Version) -- --- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. - --- This is the VMS version - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is digits 15; - pragma Float_Representation (IEEE_Float, Double); - -- Type Double is the type used to call the C routines. Note that this - -- is IEEE format even when running on VMS with VAX_Native representation - -- since we use the IEEE version of the C library with VMS. - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "MATH$SIN_T"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "MATH$COS_T"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "MATH$TAN_T"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "MATH$EXP_T"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "MATH$SQRT_T"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "DECC$TLOG_2"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "MATH$ACOS_T"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "MATH$ASIN_T"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "MATH$ATAN_T"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "MATH$SINH_T"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "MATH$COSH_T"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "MATH$TANH_T"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "DECC$TPOW_2"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/main/gcc/ada/a-numaux-vxworks.ads b/main/gcc/ada/a-numaux-vxworks.ads index ce567ad6586..5fdf778b345 100644 --- a/main/gcc/ada/a-numaux-vxworks.ads +++ b/main/gcc/ada/a-numaux-vxworks.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (C Library Version, VxWorks) -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,23 +30,12 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. --- One advantage of using this package is that it will interface directly to --- hardware instructions, such as the those provided on the Intel x86. - --- Note: there are two versions of this package. One using the normal IEEE --- 64-bit double format (which is this version), and one using 80-bit x86 --- long double (see file 4onumaux.ads). +-- Version for use on VxWorks (where we have no libm.a library), so the pragma +-- Linker_Options ("-lm") is omitted in this version. package Ada.Numerics.Aux is pragma Pure; - -- This version omits the pragma linker_options ("-lm") since there is - -- no libm.a library for VxWorks. - type Double is digits 15; -- Type Double is the type used to call the C routines diff --git a/main/gcc/ada/a-numaux-x86.adb b/main/gcc/ada/a-numaux-x86.adb index 811485d859b..5f245a2c37b 100644 --- a/main/gcc/ada/a-numaux-x86.adb +++ b/main/gcc/ada/a-numaux-x86.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Machine Version for x86) -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +30,6 @@ -- -- ------------------------------------------------------------------------------ --- File a-numaux.adb <- 86numaux.adb - --- This version of Numerics.Aux is for the IEEE Double Extended floating --- point format on x86. - with System.Machine_Code; use System.Machine_Code; package body Ada.Numerics.Aux is diff --git a/main/gcc/ada/a-numaux-x86.ads b/main/gcc/ada/a-numaux-x86.ads index 7211fbb64ce..bf8b49c02ef 100644 --- a/main/gcc/ada/a-numaux-x86.ads +++ b/main/gcc/ada/a-numaux-x86.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Machine Version for x86) -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ -- -- ------------------------------------------------------------------------------ --- This package provides the basic computational interface for the generic --- elementary functions. This implementation is based on the glibc assembly --- sources for the x86 glibc math library. - --- Note: there are two versions of this package. One using the 80-bit x86 --- long double format (which is this version), and one using 64-bit IEEE --- double (see file a-numaux.ads). The latter version imports the C --- routines directly. +-- Version for the x86, using 64-bit IEEE format with inline asm statements package Ada.Numerics.Aux is pragma Pure; diff --git a/main/gcc/ada/a-numaux.ads b/main/gcc/ada/a-numaux.ads index cef530183f5..f69fdc10da1 100644 --- a/main/gcc/ada/a-numaux.ads +++ b/main/gcc/ada/a-numaux.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (C Library Version, non-x86) -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +37,13 @@ -- One advantage of using this package is that it will interface directly to -- hardware instructions, such as the those provided on the Intel x86. --- This version is for use with normal Unix math functions. Alternative --- packages are used on OpenVMS (different import names), VxWorks (no --- need for the -lm Linker_Options), and on the x86 (where we have two --- versions one using inline ASM, and one importing from the C long --- routines that take 80-bit arguments). +-- This version here is for use with normal Unix math functions. Alternative +-- versions are provided for special situations: + +-- a-numaux-darwin For OS/X (special handling of sin/cos for accuracy) +-- a-numaux-libc-x86 For the x86, using 80-bit long double format +-- a-numaux-x86 For the x86, using 64-bit IEEE (inline asm statements) +-- a-numaux-vxworks For use on VxWorks (where we have no libm.a library) package Ada.Numerics.Aux is pragma Pure; diff --git a/main/gcc/ada/a-rbtgbo.adb b/main/gcc/ada/a-rbtgbo.adb index ddf3fe2262a..99a2edc2e36 100644 --- a/main/gcc/ada/a-rbtgbo.adb +++ b/main/gcc/ada/a-rbtgbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +27,9 @@ -- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------ --- The references below to "CLR" refer to the following book, from which --- several of the algorithms here were adapted: +-- The references in this file to "CLR" refer to the following book, from +-- which several of the algorithms here were adapted: + -- Introduction to Algorithms -- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest -- Publisher: The MIT Press (June 18, 1990) @@ -89,9 +90,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is begin X := Node; - while X /= Tree.Root - and then Color (N (X)) = Black - loop + while X /= Tree.Root and then Color (N (X)) = Black loop if X = Left (N (Parent (N (X)))) then W := Right (N (Parent (N (X)))); @@ -103,7 +102,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is end if; if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) - and then + and then (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) then Set_Color (N (W), Red); @@ -147,7 +146,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is end if; if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) - and then + and then (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) then Set_Color (N (W), Red); @@ -196,7 +195,6 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is X, Y : Count_Type; Z : constant Count_Type := Node; - pragma Assert (Z /= 0); N : Nodes_Type renames Tree.Nodes; @@ -206,6 +204,12 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is "attempt to tamper with cursors (container is busy)"; end if; + -- If node is not present, return (exception will be raised in caller) + + if Z = 0 then + return; + end if; + pragma Assert (Tree.Length > 0); pragma Assert (Tree.Root /= 0); pragma Assert (Tree.First /= 0); @@ -213,8 +217,8 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is pragma Assert (Parent (N (Tree.Root)) = 0); pragma Assert ((Tree.Length > 1) - or else (Tree.First = Tree.Last - and then Tree.First = Tree.Root)); + or else (Tree.First = Tree.Last + and then Tree.First = Tree.Root)); pragma Assert ((Left (N (Node)) = 0) or else (Parent (N (Left (N (Node)))) = Node)); @@ -821,6 +825,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is ----------------- procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is + -- CLR p. 266 N : Nodes_Type renames Tree.Nodes; @@ -924,9 +929,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Y : Count_Type := Parent (Tree.Nodes (Node)); begin - while Y /= 0 - and then X = Right (Tree.Nodes (Y)) - loop + while Y /= 0 and then X = Right (Tree.Nodes (Y)) loop X := Y; Y := Parent (Tree.Nodes (Y)); end loop; @@ -957,9 +960,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is Y : Count_Type := Parent (Tree.Nodes (Node)); begin - while Y /= 0 - and then X = Left (Tree.Nodes (Y)) - loop + while Y /= 0 and then X = Left (Tree.Nodes (Y)) loop X := Y; Y := Parent (Tree.Nodes (Y)); end loop; @@ -1130,28 +1131,20 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is end if; if Tree.Length = 2 then - if Tree.First /= Tree.Root - and then Tree.Last /= Tree.Root - then + if Tree.First /= Tree.Root and then Tree.Last /= Tree.Root then return False; end if; - if Tree.First /= Index - and then Tree.Last /= Index - then + if Tree.First /= Index and then Tree.Last /= Index then return False; end if; end if; - if Left (Node) /= 0 - and then Parent (Nodes (Left (Node))) /= Index - then + if Left (Node) /= 0 and then Parent (Nodes (Left (Node))) /= Index then return False; end if; - if Right (Node) /= 0 - and then Parent (Nodes (Right (Node))) /= Index - then + if Right (Node) /= 0 and then Parent (Nodes (Right (Node))) /= Index then return False; end if; diff --git a/main/gcc/ada/a-rttiev.adb b/main/gcc/ada/a-rttiev.adb index 67b81c72ba8..ecb0aa7c9d5 100644 --- a/main/gcc/ada/a-rttiev.adb +++ b/main/gcc/ada/a-rttiev.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2005-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2005-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,15 @@ package body Ada.Real_Time.Timing_Events is Event_Queue_Lock : aliased System.Task_Primitives.RTS_Lock; -- Used for mutually exclusive access to All_Events + -- We need to Initialize_Lock before Timer is activated. The purpose of the + -- Dummy package is to get around Ada's syntax rules. + + package Dummy is end Dummy; + package body Dummy is + begin + Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level); + end Dummy; + procedure Process_Queued_Events; -- Examine the queue of pending events for any that have timed out. For -- those that have timed out, remove them from the queue and invoke their @@ -86,7 +95,6 @@ package body Ada.Real_Time.Timing_Events is task Timer is pragma Priority (System.Priority'Last); - entry Start; end Timer; task body Timer is @@ -96,29 +104,16 @@ package body Ada.Real_Time.Timing_Events is -- requirements. Obviously a shorter period would give better resolution -- at the cost of more overhead. - begin - System.Tasking.Utilities.Make_Independent; + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + pragma Unreferenced (Ignore); + begin -- Since this package may be elaborated before System.Interrupt, -- we need to call Setup_Interrupt_Mask explicitly to ensure that -- this task has the proper signal mask. System.Interrupt_Management.Operations.Setup_Interrupt_Mask; - -- We await the call to Start to ensure that Event_Queue_Lock has been - -- initialized by the package executable part prior to accessing it in - -- the loop. The task is activated before the first statement of the - -- executable part so it would otherwise be possible for the task to - -- call EnterCriticalSection in Process_Queued_Events before the - -- initialization. - - -- We don't simply put the initialization here, prior to the loop, - -- because other application tasks could call the visible routines that - -- also call Enter/LeaveCriticalSection prior to this task doing the - -- initialization. - - accept Start; - loop Process_Queued_Events; delay until Clock + Period; @@ -369,7 +364,4 @@ package body Ada.Real_Time.Timing_Events is Remove_From_Queue (This'Unchecked_Access); end Finalize; -begin - Initialize_Lock (Event_Queue_Lock'Access, Level => PO_Level); - Timer.Start; end Ada.Real_Time.Timing_Events; diff --git a/main/gcc/ada/a-strbou.ads b/main/gcc/ada/a-strbou.ads index ddc8c337683..7703b728107 100644 --- a/main/gcc/ada/a-strbou.ads +++ b/main/gcc/ada/a-strbou.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- @@ -607,7 +607,7 @@ package Ada.Strings.Bounded is High : Natural) renames Super_Slice; - function "=" + overriding function "=" (Left : Bounded_String; Right : Bounded_String) return Boolean renames Equal; diff --git a/main/gcc/ada/a-stream.ads b/main/gcc/ada/a-stream.ads index 75810f3dacd..388b5da27db 100644 --- a/main/gcc/ada/a-stream.ads +++ b/main/gcc/ada/a-stream.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- @@ -41,9 +41,7 @@ package Ada.Streams is type Stream_Element is mod 2 ** Standard'Storage_Unit; - type Stream_Element_Offset is range - -(2 ** (Standard'Address_Size - 1)) .. - +(2 ** (Standard'Address_Size - 1)) - 1; + type Stream_Element_Offset is range -(2 ** 63) .. +(2 ** 63) - 1; subtype Stream_Element_Count is Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; diff --git a/main/gcc/ada/a-ststio.adb b/main/gcc/ada/a-ststio.adb index ef8af62d206..fb3b59cc882 100644 --- a/main/gcc/ada/a-ststio.adb +++ b/main/gcc/ada/a-ststio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -382,17 +382,10 @@ package body Ada.Streams.Stream_IO is ------------------ procedure Set_Position (File : File_Type) is - use type System.CRTL.long; - use type System.CRTL.ssize_t; + use type System.CRTL.int64; R : int; begin - if Standard'Address_Size = 64 then - R := fseek64 (File.Stream, - System.CRTL.ssize_t (File.Index) - 1, SEEK_SET); - else - R := fseek (File.Stream, - System.CRTL.long (File.Index) - 1, SEEK_SET); - end if; + R := fseek64 (File.Stream, System.CRTL.int64 (File.Index) - 1, SEEK_SET); if R /= 0 then raise Use_Error; @@ -410,14 +403,14 @@ package body Ada.Streams.Stream_IO is if File.File_Size = -1 then File.Last_Op := Op_Other; - if fseek (File.Stream, 0, SEEK_END) /= 0 then + if fseek64 (File.Stream, 0, SEEK_END) /= 0 then raise Device_Error; end if; - if Standard'Address_Size = 64 then - File.File_Size := Stream_Element_Offset (ftell64 (File.Stream)); - else - File.File_Size := Stream_Element_Offset (ftell (File.Stream)); + File.File_Size := Stream_Element_Offset (ftell64 (File.Stream)); + + if File.File_Size = -1 then + raise Use_Error; end if; end if; diff --git a/main/gcc/ada/a-suenco.adb b/main/gcc/ada/a-suenco.adb index ea83123878b..54d142d7a65 100644 --- a/main/gcc/ada/a-suenco.adb +++ b/main/gcc/ada/a-suenco.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Ada.Strings.UTF_Encoding.Conversions is is begin -- Nothing to do if identical schemes, but for UTF_8 we need to - -- exclude overlong encodings, so need to do the full conversion. + -- handle overlong encodings, so need to do the full conversion. if Input_Scheme = Output_Scheme and then Input_Scheme /= UTF_8 @@ -50,7 +50,8 @@ package body Ada.Strings.UTF_Encoding.Conversions is return Item; -- For remaining cases, one or other of the operands is UTF-16BE/LE - -- encoded, so go through UTF-16 intermediate. + -- encoded, or we have the UTF-8 to UTF-8 case where we must handle + -- overlong encodings. In all cases, go through UTF-16 intermediate. else return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), @@ -159,7 +160,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is C := To_Unsigned_8 (Item (Iptr)); Iptr := Iptr + 1; - -- Codes in the range 16#00# - 16#7F# + -- Codes in the range 16#00# .. 16#7F# -- UTF-8: 0xxxxxxx -- UTF-16: 00000000_0xxxxxxx @@ -173,7 +174,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is elsif C <= 2#10_111111# then Raise_Encoding_Error (Iptr - 1); - -- Codes in the range 16#80# - 16#7FF# + -- Codes in the range 16#80# .. 16#7FF# -- UTF-8: 110yyyxx 10xxxxxx -- UTF-16: 00000yyy_xxxxxxxx @@ -183,7 +184,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is Len := Len + 1; Result (Len) := Wide_Character'Val (R); - -- Codes in the range 16#800# - 16#FFFF# + -- Codes in the range 16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF# -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx -- UTF-16: yyyyyyyy_xxxxxxxx @@ -201,7 +202,7 @@ package body Ada.Strings.UTF_Encoding.Conversions is Raise_Encoding_Error (Iptr - 3); end if; - -- Codes in the range 16#10000# - 16#10FFFF# + -- Codes in the range 16#10000# .. 16#10FFFF# -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx -- Note: zzzz in the output is input zzzzz - 1 @@ -212,24 +213,50 @@ package body Ada.Strings.UTF_Encoding.Conversions is -- R now has zzzzzyyyy - R := R - 2#0000_1_0000#; + -- At this stage, we check for the case where we have an overlong + -- encoding, and the encoded value in fact lies in the single word + -- range (16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF#). This means + -- that the result fits in a single result word. - -- R now has zzzzyyyy (zzzz minus one for the output) + if R <= 2#1111# then + Get_Continuation; + Get_Continuation; - Get_Continuation; + -- Make sure we are not in the forbidden surrogate range - -- R now has zzzzyyyyyyyyxx + if R in 16#D800# .. 16#DF00# then + Raise_Encoding_Error (Iptr - 3); + end if; - Len := Len + 1; - Result (Len) := - Wide_Character'Val - (2#110110_00_0000_0000# or Shift_Right (R, 4)); + -- Otherwise output a single UTF-16 value - R := R and 2#1111#; - Get_Continuation; - Len := Len + 1; - Result (Len) := - Wide_Character'Val (2#110111_00_0000_0000# or R); + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Here for normal case (code value > 16#FFFF and zzzzz non-zero) + + else + -- Subtract 1 from input zzzzz value to get output zzzz value + + R := R - 2#0000_1_0000#; + + -- R now has zzzzyyyy (zzzz minus one for the output) + + Get_Continuation; + + -- R now has zzzzyy_yyyyyyxx + + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (2#110110_00_0000_0000# or Shift_Right (R, 4)); + + R := R and 2#1111#; + Get_Continuation; + Len := Len + 1; + Result (Len) := + Wide_Character'Val (2#110111_00_0000_0000# or R); + end if; -- Any other code is an error diff --git a/main/gcc/ada/a-synbar-posix.adb b/main/gcc/ada/a-synbar-posix.adb index 73dc9fa2008..62cf23250a1 100644 --- a/main/gcc/ada/a-synbar-posix.adb +++ b/main/gcc/ada/a-synbar-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- @@ -50,7 +50,7 @@ package body Ada.Synchronous_Barriers is pragma Import (C, pthread_barrier_init, "pthread_barrier_init"); -- Initialize barrier with the attributes in attr. The barrier is opened -- when count waiters arrived. If attr is null the default barrier - -- attributes shall be used. + -- attributes are used. function pthread_barrier_destroy (barrier : not null access pthread_barrier_t) return int; @@ -76,10 +76,11 @@ package body Ada.Synchronous_Barriers is overriding procedure Initialize (Barrier : in out Synchronous_Barrier) is Result : int; begin - Result := pthread_barrier_init - (barrier => Barrier.POSIX_Barrier'Access, - attr => System.Null_Address, - count => unsigned (Barrier.Release_Threshold)); + Result := + pthread_barrier_init + (barrier => Barrier.POSIX_Barrier'Access, + attr => System.Null_Address, + count => unsigned (Barrier.Release_Threshold)); pragma Assert (Result = 0); end Initialize; @@ -98,8 +99,9 @@ package body Ada.Synchronous_Barriers is -- the barrier open. begin - Result := pthread_barrier_wait - (barrier => The_Barrier.POSIX_Barrier'Access); + Result := + pthread_barrier_wait + (barrier => The_Barrier.POSIX_Barrier'Access); pragma Assert (Result = 0 or else Result = PTHREAD_BARRIER_SERIAL_THREAD); diff --git a/main/gcc/ada/a-szmzco.ads b/main/gcc/ada/a-szmzco.ads index f54746dc783..6fbb7bf7777 100644 --- a/main/gcc/ada/a-szmzco.ads +++ b/main/gcc/ada/a-szmzco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- diff --git a/main/gcc/ada/a-tags.ads b/main/gcc/ada/a-tags.ads index 9239c998585..53a541b3b78 100644 --- a/main/gcc/ada/a-tags.ads +++ b/main/gcc/ada/a-tags.ads @@ -33,27 +33,36 @@ -- -- ------------------------------------------------------------------------------ --- The operations in this package provide the guarantee that all dispatching --- calls on primitive operations of tagged types and interfaces take constant --- time (in terms of source lines executed), that is to say, the cost of these --- calls is independent of the number of primitives of the type or interface, --- and independent of the number of ancestors or interface progenitors that a +-- For performance analysis, take into account that the operations in this +-- package provide the guarantee that all dispatching calls on primitive +-- operations of tagged types and interfaces take constant time (in terms +-- of source lines executed), that is to say, the cost of these calls is +-- independent of the number of primitives of the type or interface, and +-- independent of the number of ancestors or interface progenitors that a -- tagged type may have. -- The following subprograms of the public part of this package take constant -- time (in terms of source lines executed): -- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag, --- Is_Descendant_At_Same_Level, Parent_Tag +-- Is_Descendant_At_Same_Level, Parent_Tag, Type_Is_Abstract -- Descendant_Tag (when used with a library-level tagged type), -- Internal_Tag (when used with a library-level tagged type). --- The following subprograms of the public part of this package take non --- constant time (in terms of sources line executed): +-- The following subprograms of the public part of this package execute in +-- time that is not constant (in terms of sources line executed): --- Descendant_Tag (when used with a locally defined tagged type) --- Internal_Tag (when used with a locally defined tagged type) --- Interface_Ancestor_Tagswith System +-- Internal_Tag (when used with a locally defined tagged type), because in +-- such cases this routine processes the external tag, extracts from it an +-- address available there, and converts it into the tag value returned by +-- this function. The number of instructions executed is not constant since +-- it depends on the length of the external tag string. + +-- Descendant_Tag (when used with a locally defined tagged type), because +-- it relies on the subprogram Internal_Tag() to provide its functionality. + +-- Interface_Ancestor_Tags, because this function returns a table whose +-- length depends on the number of interfaces covered by a tagged type. with System.Storage_Elements; diff --git a/main/gcc/ada/a-tasatt.adb b/main/gcc/ada/a-tasatt.adb dissimilarity index 83% index 44cb8a93609..e0ef9b22fb5 100644 --- a/main/gcc/ada/a-tasatt.adb +++ b/main/gcc/ada/a-tasatt.adb @@ -1,762 +1,367 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A S K _ A T T R I B U T E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2010, 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- The following notes are provided in case someone decides the implementation --- of this package is too complicated, or too slow. Please read this before --- making any "simplifications". - --- Correct implementation of this package is more difficult than one might --- expect. After considering (and coding) several alternatives, we settled on --- the present compromise. Things we do not like about this implementation --- include: - --- - It is vulnerable to bad Task_Id values, to the extent of possibly --- trashing memory and crashing the runtime system. - --- - It requires dynamic storage allocation for each new attribute value, --- except for types that happen to be the same size as System.Address, or --- shorter. - --- - Instantiations at other than the library level rely on being able to --- do down-level calls to a procedure declared in the generic package body. --- This makes it potentially vulnerable to compiler changes. - --- The main implementation issue here is that the connection from task to --- attribute is a potential source of dangling references. - --- When a task goes away, we want to be able to recover all the storage --- associated with its attributes. The Ada mechanism for this is finalization, --- via controlled attribute types. For this reason, the ARM requires --- finalization of attribute values when the associated task terminates. - --- This finalization must be triggered by the tasking runtime system, during --- termination of the task. Given the active set of instantiations of --- Ada.Task_Attributes is dynamic, the number and types of attributes --- belonging to a task will not be known until the task actually terminates. --- Some of these types may be controlled and some may not. The RTS must find --- some way to determine which of these attributes need finalization, and --- invoke the appropriate finalization on them. - --- One way this might be done is to create a special finalization chain for --- each task, similar to the finalization chain that is used for controlled --- objects within the task. This would differ from the usual finalization --- chain in that it would not have a LIFO structure, since attributes may be --- added to a task at any time during its lifetime. This might be the right --- way to go for the longer term, but at present this approach is not open, --- since GNAT does not provide such special finalization support. - --- Lacking special compiler support, the RTS is limited to the normal ways an --- application invokes finalization, i.e. - --- a) Explicit call to the procedure Finalize, if we know the type has this --- operation defined on it. This is not sufficient, since we have no way --- of determining whether a given generic formal Attribute type is --- controlled, and no visibility of the associated Finalize procedure, in --- the generic body. - --- b) Leaving the scope of a local object of a controlled type. This does not --- help, since the lifetime of an instantiation of Ada.Task_Attributes --- does not correspond to the lifetimes of the various tasks which may --- have that attribute. - --- c) Assignment of another value to the object. This would not help, since --- we then have to finalize the new value of the object. - --- d) Unchecked deallocation of an object of a controlled type. This seems to --- be the only mechanism available to the runtime system for finalization --- of task attributes. - --- We considered two ways of using unchecked deallocation, both based on a --- linked list of that would hang from the task control block. - --- In the first approach the objects on the attribute list are all derived --- from one controlled type, say T, and are linked using an access type to --- T'Class. The runtime system has an Ada.Unchecked_Deallocation for T'Class --- with access type T'Class, and uses this to deallocate and finalize all the --- items in the list. The limitation of this approach is that each --- instantiation of the package Ada.Task_Attributes derives a new record --- extension of T, and since T is controlled (RM 3.9.1 (3)), instantiation is --- only allowed at the library level. - --- In the second approach the objects on the attribute list are of unrelated --- but structurally similar types. Unchecked conversion is used to circument --- Ada type checking. Each attribute-storage node contains not only the --- attribute value and a link for chaining, but also a pointer to descriptor --- for the corresponding instantiation of Task_Attributes. The instantiation --- descriptor contains pointer to a procedure that can do the correct --- deallocation and finalization for that type of attribute. On task --- termination, the runtime system uses the pointer to call the appropriate --- deallocator. - --- While this gets around the limitation that instantations be at the library --- level, it relies on an implementation feature that may not always be safe, --- i.e. that it is safe to call the Deallocate procedure for an instantiation --- of Ada.Task_Attributes that no longer exists. In general, it seems this --- might result in dangling references. - --- Another problem with instantiations deeper than the library level is that --- there is risk of storage leakage, or dangling references to reused storage. --- That is, if an instantiation of Ada.Task_Attributes is made within a --- procedure, what happens to the storage allocated for attributes, when the --- procedure call returns? Apparently (RM 7.6.1 (4)) any such objects must be --- finalized, since they will no longer be accessible, and in general one --- would expect that the storage they occupy would be recovered for later --- reuse. (If not, we would have a case of storage leakage.) Assuming the --- storage is recovered and later reused, we have potentially dangerous --- dangling references. When the procedure containing the instantiation of --- Ada.Task_Attributes returns, there may still be unterminated tasks with --- associated attribute values for that instantiation. When such tasks --- eventually terminate, the RTS will attempt to call the Deallocate procedure --- on them. If the corresponding storage has already been deallocated, when --- the master of the access type was left, we have a potential disaster. This --- disaster is compounded since the pointer to Deallocate is probably through --- a "trampoline" which will also have been destroyed. - --- For this reason, we arrange to remove all dangling references before --- leaving the scope of an instantiation. This is ugly, since it requires --- traversing the list of all tasks, but it is no more ugly than a similar --- traversal that we must do at the point of instantiation in order to --- initialize the attributes of all tasks. At least we only need to do these --- traversals if the type is controlled. - --- We chose to defer allocation of storage for attributes until the Reference --- function is called or the attribute is first set to a value different from --- the default initial one. This allows a potential savings in allocation, --- for attributes that are not used by all tasks. - --- For efficiency, we reserve space in the TCB for a fixed number of direct- --- access attributes. These are required to be of a size that fits in the --- space of an object of type System.Address. Because we must use unchecked --- bitwise copy operations on these values, they cannot be of a controlled --- type, but that is covered automatically since controlled objects are too --- large to fit in the spaces. - --- We originally deferred initialization of these direct-access attributes, --- just as we do for the indirect-access attributes, and used a per-task bit --- vector to keep track of which attributes were currently defined for that --- task. We found that the overhead of maintaining this bit-vector seriously --- slowed down access to the attributes, and made the fetch operation non- --- atomic, so that even to read an attribute value required locking the TCB. --- Therefore, we now initialize such attributes for all existing tasks at the --- time of the attribute instantiation, and initialize existing attributes for --- each new task at the time it is created. - --- The latter initialization requires a list of all the instantiation --- descriptors. Updates to this list, as well as the bit-vector that is used --- to reserve slots for attributes in the TCB, require mutual exclusion. That --- is provided by the Lock/Unlock_RTS. - --- One special problem that added complexity to the design is that the per- --- task list of indirect attributes contains objects of different types. We --- use unchecked pointer conversion to link these nodes together and access --- them, but the records may not have identical internal structure. Initially, --- we thought it would be enough to allocate all the common components of --- the records at the front of each record, so that their positions would --- correspond. Unfortunately, GNAT adds "dope" information at the front --- of a record, if the record contains any controlled-type components. --- --- This means that the offset of the fields we use to link the nodes is at --- different positions on nodes of different types. To get around this, each --- attribute storage record consists of a core node and wrapper. The core --- nodes are all of the same type, and it is these that are linked together --- and generally "seen" by the RTS. Each core node contains a pointer to its --- own wrapper, which is a record that contains the core node along with an --- attribute value, approximately as follows: - --- type Node; --- type Node_Access is access all Node; --- type Wrapper; --- type Access_Wrapper is access all Wrapper; --- type Node is record --- Next : Node_Access; --- ... --- Wrapper : Access_Wrapper; --- end record; --- type Wrapper is record --- Dummy_Node : aliased Node; --- Value : aliased Attribute; -- the generic formal type --- end record; - --- Another interesting problem is with the initialization of the instantiation --- descriptors. Originally, we did this all via the Initialize procedure of --- the descriptor type and code in the package body. It turned out that the --- Initialize procedure needed quite a bit of information, including the size --- of the attribute type, the initial value of the attribute (if it fits in --- the TCB), and a pointer to the deallocator procedure. These needed to be --- "passed" in via access discriminants. GNAT was having trouble with access --- discriminants, so all this work was moved to the package body. - --- Note that references to objects declared in this package body must in --- general use 'Unchecked_Access instead of 'Access as the package can be --- instantiated from within a local context. - -with System.Storage_Elements; -with System.Task_Primitives.Operations; -with System.Tasking; -with System.Tasking.Initialization; -with System.Tasking.Task_Attributes; - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -pragma Elaborate_All (System.Tasking.Task_Attributes); --- To ensure the initialization of object Local (below) will work - -package body Ada.Task_Attributes is - - use System.Tasking.Initialization, - System.Tasking, - System.Tasking.Task_Attributes, - Ada.Exceptions; - - package POP renames System.Task_Primitives.Operations; - - --------------------------- - -- Unchecked Conversions -- - --------------------------- - - -- The following type corresponds to Dummy_Wrapper, declared in - -- System.Tasking.Task_Attributes. - - type Wrapper; - type Access_Wrapper is access all Wrapper; - - pragma Warnings (Off); - -- We turn warnings off for the following To_Attribute_Handle conversions, - -- since these are used only for small attributes where we know that there - -- are no problems with alignment, but the compiler will generate warnings - -- for the occurrences in the large attribute case, even though they will - -- not actually be used. - - function To_Attribute_Handle is new Ada.Unchecked_Conversion - (System.Address, Attribute_Handle); - function To_Direct_Attribute_Element is new Ada.Unchecked_Conversion - (System.Address, Direct_Attribute_Element); - -- For reference to directly addressed task attributes - - type Access_Integer_Address is access all - System.Storage_Elements.Integer_Address; - - function To_Attribute_Handle is new Ada.Unchecked_Conversion - (Access_Integer_Address, Attribute_Handle); - -- For reference to directly addressed task attributes - - pragma Warnings (On); - -- End warnings off region for directly addressed attribute conversions - - function To_Access_Address is new Ada.Unchecked_Conversion - (Access_Node, Access_Address); - -- To store pointer to list of indirect attributes - - pragma Warnings (Off); - function To_Access_Wrapper is new Ada.Unchecked_Conversion - (Access_Dummy_Wrapper, Access_Wrapper); - pragma Warnings (On); - -- To fetch pointer to actual wrapper of attribute node. We turn off - -- warnings since this may generate an alignment warning. The warning can - -- be ignored since Dummy_Wrapper is only a non-generic standin for the - -- real wrapper type (we never actually allocate objects of type - -- Dummy_Wrapper). - - function To_Access_Dummy_Wrapper is new Ada.Unchecked_Conversion - (Access_Wrapper, Access_Dummy_Wrapper); - -- To store pointer to actual wrapper of attribute node - - function To_Task_Id is new Ada.Unchecked_Conversion - (Task_Identification.Task_Id, Task_Id); - -- To access TCB of identified task - - type Local_Deallocator is access procedure (P : in out Access_Node); - - function To_Lib_Level_Deallocator is new Ada.Unchecked_Conversion - (Local_Deallocator, Deallocator); - -- To defeat accessibility check - - ------------------------ - -- Storage Management -- - ------------------------ - - procedure Deallocate (P : in out Access_Node); - -- Passed to the RTS via unchecked conversion of a pointer to permit - -- finalization and deallocation of attribute storage nodes. - - -------------------------- - -- Instantiation Record -- - -------------------------- - - Local : aliased Instance; - -- Initialized in package body - - type Wrapper is record - Dummy_Node : aliased Node; - - Value : aliased Attribute := Initial_Value; - -- The generic formal type, may be controlled - end record; - - -- A number of unchecked conversions involving Wrapper_Access sources are - -- performed in this unit. We have to ensure that the designated object is - -- always strictly enough aligned. - - for Wrapper'Alignment use Standard'Maximum_Alignment; - - procedure Free is - new Ada.Unchecked_Deallocation (Wrapper, Access_Wrapper); - - procedure Deallocate (P : in out Access_Node) is - T : Access_Wrapper := To_Access_Wrapper (P.Wrapper); - begin - Free (T); - end Deallocate; - - --------------- - -- Reference -- - --------------- - - function Reference - (T : Task_Identification.Task_Id := Task_Identification.Current_Task) - return Attribute_Handle - is - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "Trying to get the reference of a "; - - begin - if TT = null then - Raise_Exception (Program_Error'Identity, Error_Message & "null task"); - end if; - - if TT.Common.State = Terminated then - Raise_Exception (Tasking_Error'Identity, - Error_Message & "terminated task"); - end if; - - -- Directly addressed case - - if Local.Index /= 0 then - - -- Return the attribute handle. Warnings off because this return - -- statement generates alignment warnings for large attributes - -- (but will never be executed in this case anyway). - - pragma Warnings (Off); - return - To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address); - pragma Warnings (On); - - -- Not directly addressed - - else - declare - P : Access_Node := To_Access_Node (TT.Indirect_Attributes); - W : Access_Wrapper; - Self_Id : constant Task_Id := POP.Self; - - begin - Defer_Abort (Self_Id); - POP.Lock_RTS; - - while P /= null loop - if P.Instance = Access_Instance'(Local'Unchecked_Access) then - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - return To_Access_Wrapper (P.Wrapper).Value'Access; - end if; - - P := P.Next; - end loop; - - -- Unlock the RTS here to follow the lock ordering rule that - -- prevent us from using new (i.e the Global_Lock) while holding - -- any other lock. - - POP.Unlock_RTS; - W := new Wrapper' - ((null, Local'Unchecked_Access, null), Initial_Value); - POP.Lock_RTS; - - P := W.Dummy_Node'Unchecked_Access; - P.Wrapper := To_Access_Dummy_Wrapper (W); - P.Next := To_Access_Node (TT.Indirect_Attributes); - TT.Indirect_Attributes := To_Access_Address (P); - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - return W.Value'Access; - - exception - when others => - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - raise; - end; - end if; - - exception - when Tasking_Error | Program_Error => - raise; - - when others => - raise Program_Error; - end Reference; - - ------------------ - -- Reinitialize -- - ------------------ - - procedure Reinitialize - (T : Task_Identification.Task_Id := Task_Identification.Current_Task) - is - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "Trying to Reinitialize a "; - - begin - if TT = null then - Raise_Exception (Program_Error'Identity, Error_Message & "null task"); - end if; - - if TT.Common.State = Terminated then - Raise_Exception (Tasking_Error'Identity, - Error_Message & "terminated task"); - end if; - - if Local.Index /= 0 then - Set_Value (Initial_Value, T); - else - declare - P, Q : Access_Node; - W : Access_Wrapper; - Self_Id : constant Task_Id := POP.Self; - - begin - Defer_Abort (Self_Id); - POP.Lock_RTS; - Q := To_Access_Node (TT.Indirect_Attributes); - - while Q /= null loop - if Q.Instance = Access_Instance'(Local'Unchecked_Access) then - if P = null then - TT.Indirect_Attributes := To_Access_Address (Q.Next); - else - P.Next := Q.Next; - end if; - - W := To_Access_Wrapper (Q.Wrapper); - Free (W); - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - return; - end if; - - P := Q; - Q := Q.Next; - end loop; - - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - - exception - when others => - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - raise; - end; - end if; - - exception - when Tasking_Error | Program_Error => - raise; - - when others => - raise Program_Error; - end Reinitialize; - - --------------- - -- Set_Value -- - --------------- - - procedure Set_Value - (Val : Attribute; - T : Task_Identification.Task_Id := Task_Identification.Current_Task) - is - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "Trying to Set the Value of a "; - - begin - if TT = null then - Raise_Exception (Program_Error'Identity, Error_Message & "null task"); - end if; - - if TT.Common.State = Terminated then - Raise_Exception (Tasking_Error'Identity, - Error_Message & "terminated task"); - end if; - - -- Directly addressed case - - if Local.Index /= 0 then - - -- Set attribute handle, warnings off, because this code can generate - -- alignment warnings with large attributes (but of course will not - -- be executed in this case, since we never have direct addressing in - -- such cases). - - pragma Warnings (Off); - To_Attribute_Handle - (TT.Direct_Attributes (Local.Index)'Address).all := Val; - pragma Warnings (On); - return; - end if; - - -- Not directly addressed - - declare - P : Access_Node := To_Access_Node (TT.Indirect_Attributes); - W : Access_Wrapper; - Self_Id : constant Task_Id := POP.Self; - - begin - Defer_Abort (Self_Id); - POP.Lock_RTS; - - while P /= null loop - - if P.Instance = Access_Instance'(Local'Unchecked_Access) then - To_Access_Wrapper (P.Wrapper).Value := Val; - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - return; - end if; - - P := P.Next; - end loop; - - -- Unlock RTS here to follow the lock ordering rule that prevent us - -- from using new (i.e the Global_Lock) while holding any other lock. - - POP.Unlock_RTS; - W := new Wrapper'((null, Local'Unchecked_Access, null), Val); - POP.Lock_RTS; - P := W.Dummy_Node'Unchecked_Access; - P.Wrapper := To_Access_Dummy_Wrapper (W); - P.Next := To_Access_Node (TT.Indirect_Attributes); - TT.Indirect_Attributes := To_Access_Address (P); - - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - - exception - when others => - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - raise; - end; - - exception - when Tasking_Error | Program_Error => - raise; - - when others => - raise Program_Error; - end Set_Value; - - ----------- - -- Value -- - ----------- - - function Value - (T : Task_Identification.Task_Id := Task_Identification.Current_Task) - return Attribute - is - TT : constant Task_Id := To_Task_Id (T); - Error_Message : constant String := "Trying to get the Value of a "; - - begin - if TT = null then - Raise_Exception (Program_Error'Identity, Error_Message & "null task"); - end if; - - if TT.Common.State = Terminated then - Raise_Exception - (Program_Error'Identity, Error_Message & "terminated task"); - end if; - - -- Directly addressed case - - if Local.Index /= 0 then - - -- Get value of attribute. We turn Warnings off, because for large - -- attributes, this code can generate alignment warnings. But of - -- course large attributes are never directly addressed so in fact - -- we will never execute the code in this case. - - pragma Warnings (Off); - return To_Attribute_Handle - (TT.Direct_Attributes (Local.Index)'Address).all; - pragma Warnings (On); - end if; - - -- Not directly addressed - - declare - P : Access_Node; - Result : Attribute; - Self_Id : constant Task_Id := POP.Self; - - begin - Defer_Abort (Self_Id); - POP.Lock_RTS; - P := To_Access_Node (TT.Indirect_Attributes); - - while P /= null loop - if P.Instance = Access_Instance'(Local'Unchecked_Access) then - Result := To_Access_Wrapper (P.Wrapper).Value; - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - return Result; - end if; - - P := P.Next; - end loop; - - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - return Initial_Value; - - exception - when others => - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - raise; - end; - - exception - when Tasking_Error | Program_Error => - raise; - - when others => - raise Program_Error; - end Value; - --- Start of elaboration code for package Ada.Task_Attributes - -begin - -- This unchecked conversion can give warnings when alignments are - -- incorrect, but they will not be used in such cases anyway, so the - -- warnings can be safely ignored. - - pragma Warnings (Off); - Local.Deallocate := To_Lib_Level_Deallocator (Deallocate'Access); - pragma Warnings (On); - - declare - Two_To_J : Direct_Index_Vector; - Self_Id : constant Task_Id := POP.Self; - begin - Defer_Abort (Self_Id); - - -- Need protection for updating links to per-task initialization and - -- finalization routines, in case some task is being created or - -- terminated concurrently. - - POP.Lock_RTS; - - -- Add this instantiation to the list of all instantiations - - Local.Next := System.Tasking.Task_Attributes.All_Attributes; - System.Tasking.Task_Attributes.All_Attributes := - Local'Unchecked_Access; - - -- Try to find space for the attribute in the TCB - - Local.Index := 0; - Two_To_J := 1; - - if Attribute'Size <= System.Address'Size then - for J in Direct_Index_Range loop - if (Two_To_J and In_Use) = 0 then - - -- Reserve location J for this attribute - - In_Use := In_Use or Two_To_J; - Local.Index := J; - - -- This unchecked conversion can give a warning when the - -- alignment is incorrect, but it will not be used in such - -- a case anyway, so the warning can be safely ignored. - - pragma Warnings (Off); - To_Attribute_Handle (Local.Initial_Value'Access).all := - Initial_Value; - pragma Warnings (On); - - exit; - end if; - - Two_To_J := Two_To_J * 2; - end loop; - end if; - - -- Attribute goes directly in the TCB - - if Local.Index /= 0 then - -- Replace stub for initialization routine that is called at task - -- creation. - - Initialization.Initialize_Attributes_Link := - System.Tasking.Task_Attributes.Initialize_Attributes'Access; - - -- Initialize the attribute, for all tasks - - declare - C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; - begin - while C /= null loop - C.Direct_Attributes (Local.Index) := - To_Direct_Attribute_Element - (System.Storage_Elements.To_Address (Local.Initial_Value)); - C := C.Common.All_Tasks_Link; - end loop; - end; - - -- Attribute goes into a node onto a linked list - - else - -- Replace stub for finalization routine called at task termination - - Initialization.Finalize_Attributes_Link := - System.Tasking.Task_Attributes.Finalize_Attributes'Access; - end if; - - POP.Unlock_RTS; - Undefer_Abort (Self_Id); - end; -end Ada.Task_Attributes; +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A S K _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; +with System.Tasking.Initialization; +with System.Tasking.Task_Attributes; +pragma Elaborate_All (System.Tasking.Task_Attributes); + +with System.Task_Primitives.Operations; + +with Ada.Finalization; use Ada.Finalization; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body Ada.Task_Attributes is + + use System, + System.Tasking.Initialization, + System.Tasking, + System.Tasking.Task_Attributes; + + package STPO renames System.Task_Primitives.Operations; + + type Attribute_Cleanup is new Limited_Controlled with null record; + procedure Finalize (Cleanup : in out Attribute_Cleanup); + -- Finalize all tasks' attributes for this package + + Cleanup : Attribute_Cleanup; + pragma Unreferenced (Cleanup); + -- Will call Finalize when this instantiation gets out of scope + + --------------------------- + -- Unchecked Conversions -- + --------------------------- + + type Real_Attribute is record + Free : Deallocator; + Value : Attribute; + end record; + type Real_Attribute_Access is access all Real_Attribute; + pragma No_Strict_Aliasing (Real_Attribute_Access); + -- Each value in the task control block's Attributes array is either + -- mapped to the attribute value directly if Fast_Path is True, or + -- is in effect a Real_Attribute_Access. + -- + -- Note: the Deallocator field must be first, for compatibility with + -- System.Tasking.Task_Attributes.Attribute_Record and to allow unchecked + -- conversions between Attribute_Access and Real_Attribute_Access. + + function New_Attribute (Val : Attribute) return Atomic_Address; + -- Create a new Real_Attribute using Val, and return its address. The + -- returned value can be converted via To_Real_Attribute. + + procedure Deallocate (Ptr : Atomic_Address); + -- Free memory associated with Ptr, a Real_Attribute_Access in reality + + function To_Real_Attribute is new + Ada.Unchecked_Conversion (Atomic_Address, Real_Attribute_Access); + + pragma Warnings (Off); + -- Kill warning about possible size mismatch + + function To_Address is new + Ada.Unchecked_Conversion (Attribute, Atomic_Address); + function To_Attribute is new + Ada.Unchecked_Conversion (Atomic_Address, Attribute); + + pragma Warnings (On); + + function To_Address is new + Ada.Unchecked_Conversion (Real_Attribute_Access, Atomic_Address); + + pragma Warnings (Off); + -- Kill warning about possible aliasing + + function To_Handle is new + Ada.Unchecked_Conversion (System.Address, Attribute_Handle); + + pragma Warnings (On); + + function To_Task_Id is new + Ada.Unchecked_Conversion (Task_Identification.Task_Id, Task_Id); + -- To access TCB of identified task + + procedure Free is new + Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access); + + Fast_Path : constant Boolean := + Attribute'Size <= Atomic_Address'Size + and then Attribute'Alignment <= Atomic_Address'Alignment + and then To_Address (Initial_Value) = 0; + -- 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 + -- a level of indirection and instead use Attributes (Index) as a + -- Real_Attribute_Access. + + Index : constant Integer := + Next_Index (Require_Finalization => not Fast_Path); + -- Index in the task control block's Attributes array + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Cleanup : in out Attribute_Cleanup) is + pragma Unreferenced (Cleanup); + + begin + STPO.Lock_RTS; + + declare + C : System.Tasking.Task_Id := System.Tasking.All_Tasks_List; + + begin + while C /= null loop + STPO.Write_Lock (C); + + if C.Attributes (Index) /= 0 + and then Require_Finalization (Index) + then + Deallocate (C.Attributes (Index)); + C.Attributes (Index) := 0; + end if; + + STPO.Unlock (C); + C := C.Common.All_Tasks_Link; + end loop; + end; + + Finalize (Index); + STPO.Unlock_RTS; + end Finalize; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate (Ptr : Atomic_Address) is + Obj : Real_Attribute_Access := To_Real_Attribute (Ptr); + begin + Free (Obj); + end Deallocate; + + ------------------- + -- New_Attribute -- + ------------------- + + function New_Attribute (Val : Attribute) return Atomic_Address is + Tmp : Real_Attribute_Access; + begin + Tmp := new Real_Attribute'(Free => Deallocate'Unrestricted_Access, + Value => Val); + return To_Address (Tmp); + end New_Attribute; + + --------------- + -- Reference -- + --------------- + + function Reference + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + return Attribute_Handle + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "trying to get the reference of a "; + Result : Attribute_Handle; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + -- Kill warning about possible alignment mismatch. If this happens, + -- Fast_Path will be False anyway + pragma Warnings (Off); + return To_Handle (TT.Attributes (Index)'Address); + pragma Warnings (On); + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + if TT.Attributes (Index) = 0 then + TT.Attributes (Index) := New_Attribute (Initial_Value); + end if; + + Result := To_Handle + (To_Real_Attribute (TT.Attributes (Index)).Value'Address); + Task_Unlock (Self_Id); + + return Result; + end if; + end Reference; + + ------------------ + -- Reinitialize -- + ------------------ + + procedure Reinitialize + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "Trying to Reinitialize a "; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + + -- No finalization needed, simply reset to Initial_Value + + TT.Attributes (Index) := To_Address (Initial_Value); + + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + declare + Attr : Atomic_Address renames TT.Attributes (Index); + begin + if Attr /= 0 then + Deallocate (Attr); + Attr := 0; + end if; + end; + + Task_Unlock (Self_Id); + end if; + end Reinitialize; + + --------------- + -- Set_Value -- + --------------- + + procedure Set_Value + (Val : Attribute; + T : Task_Identification.Task_Id := Task_Identification.Current_Task) + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "trying to set the value of a "; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + + -- No finalization needed, simply set to Val + + TT.Attributes (Index) := To_Address (Val); + + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + declare + Attr : Atomic_Address renames TT.Attributes (Index); + + begin + if Attr /= 0 then + Deallocate (Attr); + end if; + + Attr := New_Attribute (Val); + end; + + Task_Unlock (Self_Id); + end if; + end Set_Value; + + ----------- + -- Value -- + ----------- + + function Value + (T : Task_Identification.Task_Id := Task_Identification.Current_Task) + return Attribute + is + Self_Id : Task_Id; + TT : constant Task_Id := To_Task_Id (T); + Error_Message : constant String := "trying to get the value of a "; + + begin + if TT = null then + raise Program_Error with Error_Message & "null task"; + end if; + + if TT.Common.State = Terminated then + raise Tasking_Error with Error_Message & "terminated task"; + end if; + + if Fast_Path then + return To_Attribute (TT.Attributes (Index)); + + else + Self_Id := STPO.Self; + Task_Lock (Self_Id); + + declare + Attr : Atomic_Address renames TT.Attributes (Index); + + begin + if Attr = 0 then + Task_Unlock (Self_Id); + return Initial_Value; + + else + declare + Result : constant Attribute := + To_Real_Attribute (Attr).Value; + begin + Task_Unlock (Self_Id); + return Result; + end; + end if; + end; + end if; + end Value; + +end Ada.Task_Attributes; diff --git a/main/gcc/ada/a-tasatt.ads b/main/gcc/ada/a-tasatt.ads index ebcf253a4d8..a3e1f0eddc3 100644 --- a/main/gcc/ada/a-tasatt.ads +++ b/main/gcc/ada/a-tasatt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2014, 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 -- @@ -41,28 +41,52 @@ 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). + + -- Other types and initial values are supported, but will require + -- the use of locking and a level of indirection (meaning extra dynamic + -- memory allocation). + + -- The maximum number of task attributes supported by this implementation + -- is determined by the constant System.Parameters.Max_Attribute_Count. + -- If you exceed this number, Storage_Error will be raised during the + -- elaboration of the instantiation of this package. + type Attribute_Handle is access all Attribute; function Value - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return Attribute; + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Attribute; + -- Return the value of the corresponding attribute of T. Tasking_Error + -- is raised if T is terminated and Program_Error will be raised if T + -- is Null_Task_Id. function Reference - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task) return Attribute_Handle; + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task) return Attribute_Handle; + -- Return an access value that designates the corresponding attribute of + -- T. Tasking_Error is raised if T is terminated and Program_Error will be + -- raised if T is Null_Task_Id. procedure Set_Value (Val : Attribute; T : Ada.Task_Identification.Task_Id := Ada.Task_Identification.Current_Task); + -- Finalize the old value of the attribute of T and assign Val to that + -- attribute. Tasking_Error is raised if T is terminated and Program_Error + -- will be raised if T is Null_Task_Id. procedure Reinitialize - (T : Ada.Task_Identification.Task_Id := - Ada.Task_Identification.Current_Task); + (T : Ada.Task_Identification.Task_Id := + Ada.Task_Identification.Current_Task); + -- Same as Set_Value (Initial_Value, T). Tasking_Error is raised if T is + -- terminated and Program_Error will be raised if T is Null_Task_Id. private pragma Inline (Value); + pragma Inline (Reference); pragma Inline (Set_Value); pragma Inline (Reinitialize); - end Ada.Task_Attributes; diff --git a/main/gcc/ada/a-timoau.ads b/main/gcc/ada/a-timoau.ads index 200184f2570..3520b5688ce 100644 --- a/main/gcc/ada/a-timoau.ads +++ b/main/gcc/ada/a-timoau.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/a-ztmoau.adb b/main/gcc/ada/a-ztmoau.adb index 4ade5899774..f8d72955aa6 100644 --- a/main/gcc/ada/a-ztmoau.adb +++ b/main/gcc/ada/a-ztmoau.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/adabkend.adb b/main/gcc/ada/adabkend.adb index 1e1a2d9b2c9..1a420009100 100644 --- a/main/gcc/ada/adabkend.adb +++ b/main/gcc/ada/adabkend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, AdaCore -- +-- Copyright (C) 2001-2014, 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- -- @@ -108,7 +108,16 @@ package body Adabkend is elsif Switch_Chars (First .. Last) = "o" then if First = Last then - Opt.Output_File_Name_Present := True; + 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); @@ -237,10 +246,11 @@ package body Adabkend is -- 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. + -- 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 then + elsif GNATprove_Mode or CodePeer_Mode then Output_File_Name_Seen := True; else diff --git a/main/gcc/ada/adaint.c b/main/gcc/ada/adaint.c index 81b2d147521..02bce453297 100644 --- a/main/gcc/ada/adaint.c +++ b/main/gcc/ada/adaint.c @@ -71,12 +71,6 @@ #include #endif -#ifdef VMS -#define _POSIX_EXIT 1 -#define HOST_EXECUTABLE_SUFFIX ".exe" -#define HOST_OBJECT_SUFFIX ".obj" -#endif - #ifdef __PikeOS__ #define __BSD_VISIBLE 1 #endif @@ -87,9 +81,6 @@ #include #include #include -#ifdef VMS -#include -#endif #if defined (__vxworks) || defined (__ANDROID__) /* S_IREAD and S_IWRITE are not defined in VxWorks or Android */ @@ -147,7 +138,7 @@ UINT CurrentCCSEncoding; #include #undef VMOS_DEV -#elif !defined (VMS) +#else #include #endif @@ -174,75 +165,17 @@ UINT CurrentCCSEncoding; #endif #if defined (_WIN32) -#elif defined (VMS) - -/* Header files and definitions for __gnat_set_file_time_name. */ - -#define __NEW_STARLET 1 -#include -#include -#include -#include -#include -#include -#include -#include -#include - -/* Use native 64-bit arithmetic. */ -#define unix_time_to_vms(X,Y) \ - { \ - unsigned long long reftime, tmptime = (X); \ - $DESCRIPTOR (unixtime,"1-JAN-1970 0:00:00.00"); \ - SYS$BINTIM (&unixtime, &reftime); \ - Y = tmptime * 10000000 + reftime; \ - } -/* descrip.h doesn't have everything ... */ -typedef struct fibdef* __fibdef_ptr32 __attribute__ (( mode (SI) )); -struct dsc$descriptor_fib -{ - unsigned int fib$l_len; - __fibdef_ptr32 fib$l_addr; -}; - -/* I/O Status Block. */ -struct IOSB -{ - unsigned short status, count; - unsigned int devdep; -}; - -static char *tryfile; - -/* Variable length string. */ -struct vstring -{ - short length; - char string[NAM$C_MAXRSS+1]; -}; - -#define SYI$_ACTIVECPU_CNT 0x111e -extern int LIB$GETSYI (int *, unsigned int *); -extern unsigned int LIB$CALLG_64 (unsigned long long argument_list [], - int (*user_procedure)(void)); - -#else -#include -#endif - -#if defined (_WIN32) #include -#endif - -#if defined (_WIN32) - #include #include #include #include #undef DIR_SEPARATOR #define DIR_SEPARATOR '\\' + +#else +#include #endif #include "adaint.h" @@ -315,27 +248,12 @@ char __gnat_path_separator = PATH_SEPARATOR; as well. This is only a temporary work-around for 3.11b. */ #ifndef GNAT_LIBRARY_TEMPLATE -#if defined (VMS) -#define GNAT_LIBRARY_TEMPLATE "*.olb" -#else #define GNAT_LIBRARY_TEMPLATE "lib*.a" #endif -#endif const char *__gnat_library_template = GNAT_LIBRARY_TEMPLATE; -/* This variable is used in hostparm.ads to say whether the host is a VMS - system. */ -#ifdef VMS -int __gnat_vmsp = 1; -#else -int __gnat_vmsp = 0; -#endif - -#if defined (VMS) -#define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */ - -#elif defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__) +#if defined (__vxworks) || defined (__OPENNT) || defined(__nucleus__) #define GNAT_MAX_PATH_LEN PATH_MAX #else @@ -382,37 +300,7 @@ int __gnat_use_acl = 1; system provides the routine readdir_r. */ #undef HAVE_READDIR_R -#if defined(VMS) && defined (__LONG_POINTERS) - -/* Return a 32 bit pointer to an array of 32 bit pointers - given a 64 bit pointer to an array of 64 bit pointers */ - -typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI))); - -static __char_ptr_char_ptr32 -to_ptr32 (char **ptr64) -{ - int argc; - __char_ptr_char_ptr32 short_argv; - - for (argc = 0; ptr64[argc]; argc++) - ; - - /* Reallocate argv with 32 bit pointers. */ - short_argv = (__char_ptr_char_ptr32) decc$malloc - (sizeof (__char_ptr32) * (argc + 1)); - - for (argc = 0; ptr64[argc]; argc++) - short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]); - - short_argv[argc] = (__char_ptr32) 0; - return short_argv; - -} -#define MAYBE_TO_PTR32(argv) to_ptr32 (argv) -#else #define MAYBE_TO_PTR32(argv) argv -#endif static const char ATTR_UNSET = 127; @@ -485,12 +373,7 @@ __gnat_to_gm_time (OS_Time *p_time, int *p_year, int *p_month, int *p_day, time++; #endif -#ifdef VMS - res = localtime (&time); -#else res = gmtime (&time); -#endif - if (res) { *p_year = res->tm_year; @@ -516,7 +399,7 @@ __gnat_to_os_time (OS_Time *p_time, int year, int month, int day, v.tm_hour = hours; v.tm_min = mins; v.tm_sec = secs; - v.tm_isdst = 0; + v.tm_isdst = -1; /* returns -1 of failing, this is s-os_lib Invalid_Time */ @@ -533,7 +416,7 @@ __gnat_readlink (char *path ATTRIBUTE_UNUSED, char *buf ATTRIBUTE_UNUSED, size_t bufsiz ATTRIBUTE_UNUSED) { -#if defined (_WIN32) || defined (VMS) \ +#if defined (_WIN32) \ || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__) return -1; #else @@ -549,7 +432,7 @@ int __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, char *newpath ATTRIBUTE_UNUSED) { -#if defined (_WIN32) || defined (VMS) \ +#if defined (_WIN32) \ || defined(__vxworks) || defined (__nucleus__) || defined (__PikeOS__) return -1; #else @@ -560,7 +443,7 @@ __gnat_symlink (char *oldpath ATTRIBUTE_UNUSED, /* Try to lock a file, return 1 if success. */ #if defined (__vxworks) || defined (__nucleus__) \ - || defined (_WIN32) || defined (VMS) || defined (__PikeOS__) + || defined (_WIN32) || defined (__PikeOS__) /* Version that does not use link. */ @@ -576,7 +459,20 @@ __gnat_try_lock (char *dir, char *file) S2WSC (wdir, dir, GNAT_MAX_PATH_LEN); S2WSC (wfile, file, GNAT_MAX_PATH_LEN); + /* ??? the code below crash on MingW64 for obscure reasons, a ticket + has been opened here: + + https://sourceforge.net/p/mingw-w64/bugs/414/ + + As a workaround an equivalent set of code has been put in place below. + _stprintf (wfull_path, _T("%s%c%s"), wdir, _T(DIR_SEPARATOR), wfile); + */ + + _tcscpy (wfull_path, wdir); + _tcscat (wfull_path, L"\\"); + _tcscat (wfull_path, wfile); + fd = _topen (wfull_path, O_CREAT | O_EXCL, 0600); #else char full_path[256]; @@ -632,14 +528,7 @@ __gnat_try_lock (char *dir, char *file) int __gnat_get_maximum_file_name_length (void) { -#if defined (VMS) - if (getenv ("GNAT$EXTENDED_FILE_SPECIFICATIONS")) - return -1; - else - return 39; -#else return -1; -#endif } /* Return nonzero if file names are case sensitive. */ @@ -658,7 +547,7 @@ __gnat_get_file_names_case_sensitive (void) && sensitive[1] == '\0') file_names_case_sensitive_cache = sensitive[0] - '0'; else -#if defined (VMS) || defined (WINNT) || defined (__APPLE__) +#if defined (WINNT) || defined (__APPLE__) file_names_case_sensitive_cache = 0; #else file_names_case_sensitive_cache = 1; @@ -672,7 +561,7 @@ __gnat_get_file_names_case_sensitive (void) int __gnat_get_env_vars_case_sensitive (void) { -#if defined (VMS) || defined (WINNT) +#if defined (WINNT) return 0; #else return 1; @@ -697,9 +586,6 @@ __gnat_get_current_dir (char *dir, int *length) WS2SC (dir, wdir, GNAT_MAX_PATH_LEN); -#elif defined (VMS) - /* Force Unix style, which is what GNAT uses internally. */ - getcwd (dir, *length, 0); #else getcwd (dir, *length); #endif @@ -871,8 +757,7 @@ __gnat_fputwc(int c, FILE *stream) } FILE * -__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED, - char *vms_form ATTRIBUTE_UNUSED) +__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -888,38 +773,7 @@ __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED, S2WS (wpath, path, GNAT_MAX_PATH_LEN); return _tfopen (wpath, wmode); -#elif defined (VMS) - if (vms_form == 0) - return decc$fopen (path, mode); - else - { - char *local_form = (char *) alloca (strlen (vms_form) + 1); - /* Allocate an argument list of guaranteed ample length. */ - unsigned long long *arg_list = - (unsigned long long *) alloca (strlen (vms_form) + 3); - char *ptrb, *ptre; - int i; - - arg_list [1] = (unsigned long long) path; - arg_list [2] = (unsigned long long) mode; - strcpy (local_form, vms_form); - - /* Given a string such as "\"rfm=udf\",\"rat=cr\"" - Split it into an argument list as "rfm=udf","rat=cr". */ - ptrb = local_form; - for (i = 0; *ptrb; i++) - { - ptrb = strchr (ptrb, '"'); - ptre = strchr (ptrb + 1, '"'); - *ptre = 0; - arg_list [i + 3] = (unsigned long long) (ptrb + 1); - ptrb = ptre + 1; - } - arg_list [0] = i + 2; - /* CALLG_64 returns int , fortunately (FILE *) on VMS is a - always a 32bit pointer. */ - return LIB$CALLG_64 (arg_list, &decc$fopen); - } + #else return GNAT_FOPEN (path, mode); #endif @@ -929,8 +783,7 @@ FILE * __gnat_freopen (char *path, char *mode, FILE *stream, - int encoding ATTRIBUTE_UNUSED, - char *vms_form ATTRIBUTE_UNUSED) + int encoding ATTRIBUTE_UNUSED) { #if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS) TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -946,39 +799,6 @@ __gnat_freopen (char *path, S2WS (wpath, path, GNAT_MAX_PATH_LEN); return _tfreopen (wpath, wmode, stream); -#elif defined (VMS) - if (vms_form == 0) - return decc$freopen (path, mode, stream); - else - { - char *local_form = (char *) alloca (strlen (vms_form) + 1); - /* Allocate an argument list of guaranteed ample length. */ - unsigned long long *arg_list = - (unsigned long long *) alloca (strlen (vms_form) + 4); - char *ptrb, *ptre; - int i; - - arg_list [1] = (unsigned long long) path; - arg_list [2] = (unsigned long long) mode; - arg_list [3] = (unsigned long long) stream; - strcpy (local_form, vms_form); - - /* Given a string such as "\"rfm=udf\",\"rat=cr\"" - Split it into an argument list as "rfm=udf","rat=cr". */ - ptrb = local_form; - for (i = 0; *ptrb; i++) - { - ptrb = strchr (ptrb, '"'); - ptre = strchr (ptrb + 1, '"'); - *ptre = 0; - arg_list [i + 4] = (unsigned long long) (ptrb + 1); - ptrb = ptre + 1; - } - arg_list [0] = i + 3; - /* CALLG_64 returns int , fortunately (FILE *) on VMS is a - always a 32bit pointer. */ - return LIB$CALLG_64 (arg_list, &decc$freopen); - } #else return freopen (path, mode, stream); #endif @@ -993,11 +813,7 @@ __gnat_open_read (char *path, int fmode) if (fmode) o_fmode = O_TEXT; -#if defined (VMS) - /* Optional arguments mbc,deq,fop increase read performance. */ - fd = open (path, O_RDONLY | o_fmode, 0444, - "mbc=16", "deq=64", "fop=tef"); -#elif defined (__vxworks) +#if defined (__vxworks) fd = open (path, O_RDONLY | o_fmode, 0444); #elif defined (__MINGW32__) { @@ -1007,7 +823,7 @@ __gnat_open_read (char *path, int fmode) fd = _topen (wpath, O_RDONLY | o_fmode, 0444); } #else - fd = open (path, O_RDONLY | o_fmode); + fd = GNAT_OPEN (path, O_RDONLY | o_fmode); #endif return fd < 0 ? -1 : fd; @@ -1015,15 +831,6 @@ __gnat_open_read (char *path, int fmode) #if defined (__MINGW32__) #define PERM (S_IREAD | S_IWRITE) -#elif defined (VMS) -/* Excerpt from DECC C RTL Reference Manual: - To create files with OpenVMS RMS default protections using the UNIX - system-call functions umask, mkdir, creat, and open, call mkdir, creat, - and open with a file-protection mode argument of 0777 in a program - that never specifically calls umask. These default protections include - correctly establishing protections based on ACLs, previous versions of - files, and so on. */ -#define PERM 0777 #else #define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH) #endif @@ -1037,10 +844,7 @@ __gnat_open_rw (char *path, int fmode) if (fmode) o_fmode = O_TEXT; -#if defined (VMS) - fd = open (path, O_RDWR | o_fmode, PERM, - "mbc=16", "deq=64", "fop=tef"); -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -1048,7 +852,7 @@ __gnat_open_rw (char *path, int fmode) fd = _topen (wpath, O_RDWR | o_fmode, PERM); } #else - fd = open (path, O_RDWR | o_fmode, PERM); + fd = GNAT_OPEN (path, O_RDWR | o_fmode, PERM); #endif return fd < 0 ? -1 : fd; @@ -1063,10 +867,7 @@ __gnat_open_create (char *path, int fmode) if (fmode) o_fmode = O_TEXT; -#if defined (VMS) - fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM, - "mbc=16", "deq=64", "fop=tef"); -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -1074,7 +875,7 @@ __gnat_open_create (char *path, int fmode) fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); } #else - fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); + fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | o_fmode, PERM); #endif return fd < 0 ? -1 : fd; @@ -1084,11 +885,7 @@ int __gnat_create_output_file (char *path) { int fd; -#if defined (VMS) - fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM, - "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk", - "shr=del,get,put,upd"); -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -1096,7 +893,7 @@ __gnat_create_output_file (char *path) fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); } #else - fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); + fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT, PERM); #endif return fd < 0 ? -1 : fd; @@ -1106,11 +903,7 @@ int __gnat_create_output_file_new (char *path) { int fd; -#if defined (VMS) - fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM, - "rfm=stmlf", "ctx=rec", "rat=none", "rop=nlk", - "shr=del,get,put,upd"); -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -1118,7 +911,7 @@ __gnat_create_output_file_new (char *path) fd = _topen (wpath, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); } #else - fd = open (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); + fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_TRUNC | O_TEXT | O_EXCL, PERM); #endif return fd < 0 ? -1 : fd; @@ -1133,10 +926,7 @@ __gnat_open_append (char *path, int fmode) if (fmode) o_fmode = O_TEXT; -#if defined (VMS) - fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM, - "mbc=16", "deq=64", "fop=tef"); -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -1144,7 +934,7 @@ __gnat_open_append (char *path, int fmode) fd = _topen (wpath, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); } #else - fd = open (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); + fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_APPEND | o_fmode, PERM); #endif return fd < 0 ? -1 : fd; @@ -1161,10 +951,7 @@ __gnat_open_new (char *path, int fmode) if (fmode) o_fmode = O_TEXT; -#if defined (VMS) - fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, - "mbc=16", "deq=64", "fop=tef"); -#elif defined (__MINGW32__) +#if defined (__MINGW32__) { TCHAR wpath[GNAT_MAX_PATH_LEN]; @@ -1172,15 +959,13 @@ __gnat_open_new (char *path, int fmode) fd = _topen (wpath, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); } #else - fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); + fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); #endif return fd < 0 ? -1 : fd; } -/* Open a new temp file. Return error (-1) if the file already exists. - Special options for VMS allow the file to be shared between parent and child - processes, however they really slow down output. Used in gnatchop. */ +/* Open a new temp file. Return error (-1) if the file already exists. */ int __gnat_open_new_temp (char *path, int fmode) @@ -1205,15 +990,24 @@ __gnat_open_new_temp (char *path, int fmode) if (fmode) o_fmode = O_TEXT; -#if defined (VMS) - /* Passing rfm=stmlf for binary files seems questionable since it results - in having an extraneous line feed added after every call to CRTL write, - so pass rfm=udf (aka undefined) instead. */ - fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM, - fmode ? "rfm=stmlf" : "rfm=udf", "ctx=rec", "rat=none", - "shr=del,get,put,upd", "mbc=16", "deq=64", "fop=tef"); + fd = GNAT_OPEN (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); + return fd < 0 ? -1 : fd; +} + +int +__gnat_open (char *path, int fmode) +{ + int fd; + +#if defined (__MINGW32__) + { + TCHAR wpath[GNAT_MAX_PATH_LEN]; + + S2WSC (wpath, path, GNAT_MAX_PATH_LEN); + fd = _topen (wpath, fmode, PERM); + } #else - fd = open (path, O_WRONLY | O_CREAT | O_EXCL | o_fmode, PERM); + fd = GNAT_OPEN (path, fmode, PERM); #endif return fd < 0 ? -1 : fd; @@ -1274,12 +1068,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) if (ret != 0) { attr->timestamp = (OS_Time)-1; } else { -#ifdef VMS - /* VMS has file versioning. */ - attr->timestamp = (OS_Time)statbuf.st_ctime; -#else attr->timestamp = (OS_Time)statbuf.st_mtime; -#endif } } @@ -1287,7 +1076,7 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr) ** Return the number of bytes in the specified file ****************************************************************/ -long +__int64 __gnat_file_length_attr (int fd, char* name, struct file_attributes* attr) { if (attr->file_length == -1) { @@ -1297,7 +1086,7 @@ __gnat_file_length_attr (int fd, char* name, struct file_attributes* attr) return attr->file_length; } -long +__int64 __gnat_file_length (int fd) { struct file_attributes attr; @@ -1306,6 +1095,14 @@ __gnat_file_length (int fd) } long +__gnat_file_length_long (int fd) +{ + struct file_attributes attr; + __gnat_reset_attributes (&attr); + return (long)__gnat_file_length_attr (fd, NULL, &attr); +} + +__int64 __gnat_named_file_length (char *name) { struct file_attributes attr; @@ -1361,14 +1158,18 @@ __gnat_tmp_name (char *tmp_filename) } #elif defined (linux) || defined (__FreeBSD__) || defined (__NetBSD__) \ - || defined (__OpenBSD__) || defined(__GLIBC__) + || defined (__OpenBSD__) || defined(__GLIBC__) || defined (__ANDROID__) #define MAX_SAFE_PATH 1000 char *tmpdir = getenv ("TMPDIR"); /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid a buffer overflow. */ if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH) +#ifdef __ANDROID__ + strcpy (tmp_filename, "/cache/gnat-XXXXXX"); +#else strcpy (tmp_filename, "/tmp/gnat-XXXXXX"); +#endif else sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir); @@ -1522,7 +1323,7 @@ win32_filetime (HANDLE h) /* As above but starting from a FILETIME. */ static void -f2t (const FILETIME *ft, time_t *t) +f2t (const FILETIME *ft, __time64_t *t) { union { @@ -1531,7 +1332,7 @@ f2t (const FILETIME *ft, time_t *t) } t_write; t_write.ft_time = *ft; - *t = (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset); + *t = (__time64_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset); } #endif @@ -1544,7 +1345,7 @@ __gnat_file_time_name_attr (char* name, struct file_attributes* attr) #if defined (_WIN32) && !defined (RTX) BOOL res; WIN32_FILE_ATTRIBUTE_DATA fad; - time_t ret = -1; + __time64_t ret = -1; TCHAR wname[GNAT_MAX_PATH_LEN]; S2WSC (wname, name, GNAT_MAX_PATH_LEN); @@ -1627,168 +1428,6 @@ __gnat_set_file_time_name (char *name, time_t time_stamp) CloseHandle (h); return; -#elif defined (VMS) - struct FAB fab; - struct NAM nam; - - struct - { - unsigned long long backup, create, expire, revise; - unsigned int uic; - union - { - unsigned short value; - struct - { - unsigned system : 4; - unsigned owner : 4; - unsigned group : 4; - unsigned world : 4; - } bits; - } prot; - } Fat = { 0, 0, 0, 0, 0, { 0 }}; - - ATRDEF atrlst[] - = { - { ATR$S_CREDATE, ATR$C_CREDATE, &Fat.create }, - { ATR$S_REVDATE, ATR$C_REVDATE, &Fat.revise }, - { ATR$S_EXPDATE, ATR$C_EXPDATE, &Fat.expire }, - { ATR$S_BAKDATE, ATR$C_BAKDATE, &Fat.backup }, - { ATR$S_FPRO, ATR$C_FPRO, &Fat.prot }, - { ATR$S_UIC, ATR$C_UIC, &Fat.uic }, - { 0, 0, 0} - }; - - FIBDEF fib; - struct dsc$descriptor_fib fibdsc = {sizeof (fib), (void *) &fib}; - - struct IOSB iosb; - - unsigned long long newtime; - unsigned long long revtime; - long status; - short chan; - - struct vstring file; - struct dsc$descriptor_s filedsc - = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) file.string}; - struct vstring device; - struct dsc$descriptor_s devicedsc - = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) device.string}; - struct vstring timev; - struct dsc$descriptor_s timedsc - = {NAM$C_MAXRSS, DSC$K_DTYPE_T, DSC$K_CLASS_S, (void *) timev.string}; - struct vstring result; - struct dsc$descriptor_s resultdsc - = {NAM$C_MAXRSS, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, (void *) result.string}; - - /* Convert parameter name (a file spec) to host file form. Note that this - is needed on VMS to prepare for subsequent calls to VMS RMS library - routines. Note that it would not work to call __gnat_to_host_dir_spec - as was done in a previous version, since this fails silently unless - the feature logical DECC$EFS_CHARSET is enabled, in which case a DNF - (directory not found) condition is signalled. */ - tryfile = (char *) __gnat_to_host_file_spec (name); - - /* Allocate and initialize a FAB and NAM structures. */ - fab = cc$rms_fab; - nam = cc$rms_nam; - - nam.nam$l_esa = file.string; - nam.nam$b_ess = NAM$C_MAXRSS; - nam.nam$l_rsa = result.string; - nam.nam$b_rss = NAM$C_MAXRSS; - fab.fab$l_fna = tryfile; - fab.fab$b_fns = strlen (tryfile); - fab.fab$l_nam = &nam; - - /* Validate filespec syntax and device existence. */ - status = SYS$PARSE (&fab, 0, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - - file.string[nam.nam$b_esl] = 0; - - /* Find matching filespec. */ - status = SYS$SEARCH (&fab, 0, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - - file.string[nam.nam$b_esl] = 0; - result.string[result.length=nam.nam$b_rsl] = 0; - - /* Get the device name and assign an IO channel. */ - strncpy (device.string, nam.nam$l_dev, nam.nam$b_dev); - devicedsc.dsc$w_length = nam.nam$b_dev; - chan = 0; - status = SYS$ASSIGN (&devicedsc, &chan, 0, 0, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - - /* Initialize the FIB and fill in the directory id field. */ - memset (&fib, 0, sizeof (fib)); - fib.fib$w_did[0] = nam.nam$w_did[0]; - fib.fib$w_did[1] = nam.nam$w_did[1]; - fib.fib$w_did[2] = nam.nam$w_did[2]; - fib.fib$l_acctl = 0; - fib.fib$l_wcc = 0; - strcpy (file.string, (strrchr (result.string, ']') + 1)); - filedsc.dsc$w_length = strlen (file.string); - result.string[result.length = 0] = 0; - - /* Open and close the file to fill in the attributes. */ - status - = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, - &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - if ((iosb.status & 1) != 1) - LIB$SIGNAL (iosb.status); - - result.string[result.length] = 0; - status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, &fibdsc, 0, 0, 0, - &atrlst, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - if ((iosb.status & 1) != 1) - LIB$SIGNAL (iosb.status); - - { - time_t t; - - /* Set creation time to requested time. */ - unix_time_to_vms (time_stamp, newtime); - - t = time ((time_t) 0); - - /* Set revision time to now in local time. */ - unix_time_to_vms (t, revtime); - } - - /* Reopen the file, modify the times and then close. */ - fib.fib$l_acctl = FIB$M_WRITE; - status - = SYS$QIOW (0, chan, IO$_ACCESS|IO$M_ACCESS, &iosb, 0, 0, - &fibdsc, &filedsc, &result.length, &resultdsc, &atrlst, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - if ((iosb.status & 1) != 1) - LIB$SIGNAL (iosb.status); - - Fat.create = newtime; - Fat.revise = revtime; - - status = SYS$QIOW (0, chan, IO$_DEACCESS, &iosb, 0, 0, - &fibdsc, 0, 0, 0, &atrlst, 0); - if ((status & 1) != 1) - LIB$SIGNAL (status); - if ((iosb.status & 1) != 1) - LIB$SIGNAL (iosb.status); - - /* Deassign the channel and exit. */ - status = SYS$DASSGN (chan); - if ((status & 1) != 1) - LIB$SIGNAL (status); #else struct utimbuf utimbuf; time_t t; @@ -1921,7 +1560,8 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf) f2t (&fad.ftLastWriteTime, &statbuf->st_mtime); f2t (&fad.ftLastAccessTime, &statbuf->st_atime); - statbuf->st_size = (off_t)fad.nFileSizeLow; + statbuf->st_size = + (__int64)fad.nFileSizeLow | (__int64)fad.nFileSizeHigh << 32; /* We do not have the S_IEXEC attribute, but this is not used on GNAT. */ statbuf->st_mode = S_IREAD; @@ -2020,6 +1660,16 @@ __gnat_is_regular_file (char *name) } int +__gnat_is_regular_file_fd (int fd) +{ + int ret; + GNAT_STRUCT_STAT statbuf; + + ret = GNAT_FSTAT (fd, &statbuf); + return (!ret && S_ISREG (statbuf.st_mode)); +} + +int __gnat_is_directory_attr (char* name, struct file_attributes* attr) { if (attr->directory == ATTR_UNSET) @@ -2111,7 +1761,7 @@ __gnat_check_OWNER_ACL (TCHAR *wname, BOOL fAccessGranted = FALSE; HANDLE hToken = NULL; DWORD nLength = 0; - SECURITY_DESCRIPTOR* pSD = NULL; + PSECURITY_DESCRIPTOR pSD = NULL; GetFileSecurity (wname, OWNER_SECURITY_INFORMATION | @@ -2171,7 +1821,7 @@ __gnat_check_OWNER_ACL (TCHAR *wname, static void __gnat_set_OWNER_ACL (TCHAR *wname, - DWORD AccessMode, + ACCESS_MODE AccessMode, DWORD AccessPermissions) { PACL pOldDACL = NULL; @@ -2385,7 +2035,7 @@ __gnat_set_writable (char *name) #define S_OTHERS 4 void -__gnat_set_executable (char *name, int mode) +__gnat_set_executable (char *name, int mode ATTRIBUTE_UNUSED) { #if defined (_WIN32) && !defined (RTX) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; @@ -2540,7 +2190,7 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED) strcat (args[0], args_0); strcat (args[0], "\""); - status = spawnvp (P_WAIT, args_0, (char* const*)args); + status = spawnvp (P_WAIT, args_0, (char ** const)args); /* restore previous value */ free (args[0]); @@ -2561,11 +2211,7 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED) { /* The child. */ if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) -#if defined (VMS) - return -1; /* execv is in parent context on VMS. */ -#else _exit (1); -#endif } /* The parent. */ @@ -2639,15 +2285,6 @@ __gnat_number_of_cpus (void) GetSystemInfo (&sysinfo); cores = (int) sysinfo.dwNumberOfProcessors; -#elif defined (VMS) - int code = SYI$_ACTIVECPU_CNT; - unsigned int res; - int status; - - status = LIB$GETSYI (&code, &res); - if ((status & 1) != 0) - cores = res; - #elif defined (_WRS_CONFIG_SMP) unsigned int vxCpuConfiguredGet (void); @@ -2701,7 +2338,7 @@ add_handle (HANDLE h, int pid) { plist_max_length += 1000; HANDLES_LIST = - (void **) xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length); + (HANDLE *) xrealloc (HANDLES_LIST, sizeof (HANDLE) * plist_max_length); PID_LIST = (int *) xrealloc (PID_LIST, sizeof (int) * plist_max_length); } @@ -2821,7 +2458,6 @@ win32_wait (int *status) HANDLE *hl; HANDLE h; DWORD res; - int k; int hl_len; if (plist_length == 0) @@ -2830,8 +2466,6 @@ win32_wait (int *status) return -1; } - k = 0; - /* -------------------- critical section -------------------- */ (*Lock_Task) (); @@ -2890,11 +2524,7 @@ __gnat_portable_no_block_spawn (char *args[] ATTRIBUTE_UNUSED) { /* The child. */ if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0) -#if defined (VMS) - return -1; /* execv is in parent context on VMS. */ -#else _exit (1); -#endif } return pid; @@ -3111,12 +2741,8 @@ __gnat_locate_exec_on_path (char *exec_name) return __gnat_locate_exec (exec_name, apath_val); #else - -#ifdef VMS - char *path_val = "/VAXC$PATH"; -#else char *path_val = getenv ("PATH"); -#endif + if (path_val == NULL) return NULL; apath_val = (char *) alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); @@ -3124,492 +2750,8 @@ __gnat_locate_exec_on_path (char *exec_name) #endif } -#ifdef VMS - -/* These functions are used to translate to and from VMS and Unix syntax - file, directory and path specifications. */ - -#define MAXPATH 256 -#define MAXNAMES 256 -#define NEW_CANONICAL_FILELIST_INCREMENT 64 - -static char new_canonical_dirspec [MAXPATH]; -static char new_canonical_filespec [MAXPATH]; -static char new_canonical_pathspec [MAXNAMES*MAXPATH]; -static unsigned new_canonical_filelist_index; -static unsigned new_canonical_filelist_in_use; -static unsigned new_canonical_filelist_allocated; -static char **new_canonical_filelist; -static char new_host_pathspec [MAXNAMES*MAXPATH]; -static char new_host_dirspec [MAXPATH]; -static char new_host_filespec [MAXPATH]; - -/* Routine is called repeatedly by decc$from_vms via - __gnat_to_canonical_file_list_init until it returns 0 or the expansion - runs out. */ - -static int -wildcard_translate_unix (char *name) -{ - char *ver; - char buff [MAXPATH]; - - strncpy (buff, name, MAXPATH); - buff [MAXPATH - 1] = (char) 0; - ver = strrchr (buff, '.'); - - /* Chop off the version. */ - if (ver) - *ver = 0; - - /* Dynamically extend the allocation by the increment. */ - if (new_canonical_filelist_in_use == new_canonical_filelist_allocated) - { - new_canonical_filelist_allocated += NEW_CANONICAL_FILELIST_INCREMENT; - new_canonical_filelist = (char **) xrealloc - (new_canonical_filelist, - new_canonical_filelist_allocated * sizeof (char *)); - } - - new_canonical_filelist[new_canonical_filelist_in_use++] = xstrdup (buff); - - return 1; -} - -/* Translate a wildcard VMS file spec into a list of Unix file specs. First do - full translation and copy the results into a list (_init), then return them - one at a time (_next). If onlydirs set, only expand directory files. */ - -int -__gnat_to_canonical_file_list_init (char *filespec, int onlydirs) -{ - int len; - char buff [MAXPATH]; - - len = strlen (filespec); - strncpy (buff, filespec, MAXPATH); - - /* Only look for directories */ - if (onlydirs && !strstr (&buff [len-5], "*.dir")) - strncat (buff, "*.dir", MAXPATH); - - buff [MAXPATH - 1] = (char) 0; - - decc$from_vms (buff, wildcard_translate_unix, 1); - - /* Remove the .dir extension. */ - if (onlydirs) - { - int i; - char *ext; - - for (i = 0; i < new_canonical_filelist_in_use; i++) - { - ext = strstr (new_canonical_filelist[i], ".dir"); - if (ext) - *ext = 0; - } - } - - return new_canonical_filelist_in_use; -} - -/* Return the next filespec in the list. */ - -char * -__gnat_to_canonical_file_list_next (void) -{ - return new_canonical_filelist[new_canonical_filelist_index++]; -} - -/* Free storage used in the wildcard expansion. */ - -void -__gnat_to_canonical_file_list_free (void) -{ - int i; - - for (i = 0; i < new_canonical_filelist_in_use; i++) - free (new_canonical_filelist[i]); - - free (new_canonical_filelist); - - new_canonical_filelist_in_use = 0; - new_canonical_filelist_allocated = 0; - new_canonical_filelist_index = 0; - new_canonical_filelist = 0; -} - -/* The functional equivalent of decc$translate_vms routine. - Designed to produce the same output, but is protected against - malformed paths (original version ACCVIOs in this case) and - does not require VMS-specific DECC RTL. */ - -#define NAM$C_MAXRSS 1024 - -char * -__gnat_translate_vms (char *src) -{ - static char retbuf [NAM$C_MAXRSS + 1]; - char *srcendpos, *pos1, *pos2, *retpos; - int disp, path_present = 0; - - if (!src) - return NULL; - - srcendpos = strchr (src, '\0'); - retpos = retbuf; - - /* Look for the node and/or device in front of the path. */ - pos1 = src; - pos2 = strchr (pos1, ':'); - - if (pos2 && (pos2 < srcendpos) && (*(pos2 + 1) == ':')) - { - /* There is a node name. "node_name::" becomes "node_name!". */ - disp = pos2 - pos1; - strncpy (retbuf, pos1, disp); - retpos [disp] = '!'; - retpos = retpos + disp + 1; - pos1 = pos2 + 2; - pos2 = strchr (pos1, ':'); - } - - if (pos2) - { - /* There is a device name. "dev_name:" becomes "/dev_name/". */ - *(retpos++) = '/'; - disp = pos2 - pos1; - strncpy (retpos, pos1, disp); - retpos = retpos + disp; - pos1 = pos2 + 1; - *(retpos++) = '/'; - } - else - /* No explicit device; we must look ahead and prepend /sys$disk/ if - the path is absolute. */ - if ((*pos1 == '[' || *pos1 == '<') && (pos1 < srcendpos) - && !strchr (".-]>", *(pos1 + 1))) - { - strncpy (retpos, "/sys$disk/", 10); - retpos += 10; - } - - /* Process the path part. */ - while (*pos1 == '[' || *pos1 == '<') - { - path_present++; - pos1++; - if (*pos1 == ']' || *pos1 == '>') - { - /* Special case, [] translates to '.'. */ - *(retpos++) = '.'; - pos1++; - } - else - { - /* '[000000' means root dir. It can be present in the middle of - the path due to expansion of logical devices, in which case - we skip it. */ - if (!strncmp (pos1, "000000", 6) && path_present > 1 && - (*(pos1 + 6) == ']' || *(pos1 + 6) == '>' || *(pos1 + 6) == '.')) - { - pos1 += 6; - if (*pos1 == '.') pos1++; - } - else if (*pos1 == '.') - { - /* Relative path. */ - *(retpos++) = '.'; - } - - /* There is a qualified path. */ - while (*pos1 && *pos1 != ']' && *pos1 != '>') - { - switch (*pos1) - { - case '.': - /* '.' is used to separate directories. Replace it with '/' - but only if there isn't already '/' just before. */ - if (*(retpos - 1) != '/') - *(retpos++) = '/'; - pos1++; - if (pos1 + 1 < srcendpos - && *pos1 == '.' - && *(pos1 + 1) == '.') - { - /* Ellipsis refers to entire subtree; replace - with '**'. */ - *(retpos++) = '*'; - *(retpos++) = '*'; - *(retpos++) = '/'; - pos1 += 2; - } - break; - case '-' : - /* When after '.' '[' '<' is equivalent to Unix ".." but - there may be several in a row. */ - if (*(pos1 - 1) == '.' || *(pos1 - 1) == '[' || - *(pos1 - 1) == '<') - { - while (*pos1 == '-') - { - pos1++; - *(retpos++) = '.'; - *(retpos++) = '.'; - *(retpos++) = '/'; - } - retpos--; - break; - } - /* Otherwise fall through to default. */ - default: - *(retpos++) = *(pos1++); - } - } - pos1++; - } - } - - if (pos1 < srcendpos) - { - /* Now add the actual file name, until the version suffix if any */ - if (path_present) - *(retpos++) = '/'; - pos2 = strchr (pos1, ';'); - disp = pos2? (pos2 - pos1) : (srcendpos - pos1); - strncpy (retpos, pos1, disp); - retpos += disp; - if (pos2 && pos2 < srcendpos) - { - /* There is a non-empty version suffix. ";" becomes "." */ - *retpos++ = '.'; - disp = srcendpos - pos2 - 1; - strncpy (retpos, pos2 + 1, disp); - retpos += disp; - } - } - - *retpos = '\0'; - - return retbuf; -} - -/* Translate a VMS syntax directory specification in to Unix syntax. If - PREFIXFLAG is set, append an underscore "/". If no indicators of VMS syntax - found, return input string. Also translate a dirname that contains no - slashes, in case it's a logical name. */ - -char * -__gnat_to_canonical_dir_spec (char *dirspec, int prefixflag) -{ - int len; - - strcpy (new_canonical_dirspec, ""); - if (strlen (dirspec)) - { - char *dirspec1; - - if (strchr (dirspec, ']') || strchr (dirspec, ':')) - { - strncpy (new_canonical_dirspec, - __gnat_translate_vms (dirspec), - MAXPATH); - } - else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0) - { - strncpy (new_canonical_dirspec, - __gnat_translate_vms (dirspec1), - MAXPATH); - } - else - { - strncpy (new_canonical_dirspec, dirspec, MAXPATH); - } - } - - len = strlen (new_canonical_dirspec); - if (prefixflag && new_canonical_dirspec [len-1] != '/') - strncat (new_canonical_dirspec, "/", MAXPATH); - - new_canonical_dirspec [MAXPATH - 1] = (char) 0; - - return new_canonical_dirspec; - -} - -/* Translate a VMS syntax file specification into Unix syntax. - If no indicators of VMS syntax found, check if it's an uppercase - alphanumeric_ name and if so try it out as an environment - variable (logical name). If all else fails return the - input string. */ - -char * -__gnat_to_canonical_file_spec (char *filespec) -{ - char *filespec1; - - strncpy (new_canonical_filespec, "", MAXPATH); - - if (strchr (filespec, ']') || strchr (filespec, ':')) - { - char *tspec = (char *) __gnat_translate_vms (filespec); - - if (tspec != (char *) -1) - strncpy (new_canonical_filespec, tspec, MAXPATH); - } - else if ((strlen (filespec) == strspn (filespec, - "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_")) - && (filespec1 = getenv (filespec))) - { - char *tspec = (char *) __gnat_translate_vms (filespec1); - - if (tspec != (char *) -1) - strncpy (new_canonical_filespec, tspec, MAXPATH); - } - else - { - strncpy (new_canonical_filespec, filespec, MAXPATH); - } - - new_canonical_filespec [MAXPATH - 1] = (char) 0; - - return new_canonical_filespec; -} - -/* Translate a VMS syntax path specification into Unix syntax. - If no indicators of VMS syntax found, return input string. */ - -char * -__gnat_to_canonical_path_spec (char *pathspec) -{ - char *curr, *next, buff [MAXPATH]; - - if (pathspec == 0) - return pathspec; - - /* If there are /'s, assume it's a Unix path spec and return. */ - if (strchr (pathspec, '/')) - return pathspec; - - new_canonical_pathspec[0] = 0; - curr = pathspec; - - for (;;) - { - next = strchr (curr, ','); - if (next == 0) - next = strchr (curr, 0); - - strncpy (buff, curr, next - curr); - buff[next - curr] = 0; - - /* Check for wildcards and expand if present. */ - if (strchr (buff, '*') || strchr (buff, '%') || strstr (buff, "...")) - { - int i, dirs; - - dirs = __gnat_to_canonical_file_list_init (buff, 1); - for (i = 0; i < dirs; i++) - { - char *next_dir; - - next_dir = __gnat_to_canonical_file_list_next (); - strncat (new_canonical_pathspec, next_dir, MAXPATH); - - /* Don't append the separator after the last expansion. */ - if (i+1 < dirs) - strncat (new_canonical_pathspec, ":", MAXPATH); - } - - __gnat_to_canonical_file_list_free (); - } - else - strncat (new_canonical_pathspec, - __gnat_to_canonical_dir_spec (buff, 0), MAXPATH); - - if (*next == 0) - break; - - strncat (new_canonical_pathspec, ":", MAXPATH); - curr = next + 1; - } - - new_canonical_pathspec [MAXPATH - 1] = (char) 0; - - return new_canonical_pathspec; -} - -static char filename_buff [MAXPATH]; - -static int -translate_unix (char *name, int type ATTRIBUTE_UNUSED) -{ - strncpy (filename_buff, name, MAXPATH); - filename_buff [MAXPATH - 1] = (char) 0; - return 0; -} - -/* Translate a Unix syntax directory specification into VMS syntax. The - PREFIXFLAG has no effect, but is kept for symmetry with - to_canonical_dir_spec. If indicators of VMS syntax found, return input - string. */ - -char * -__gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED) -{ - int len = strlen (dirspec); - - strncpy (new_host_dirspec, dirspec, MAXPATH); - new_host_dirspec [MAXPATH - 1] = (char) 0; - - if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':')) - return new_host_dirspec; - - while (len > 1 && new_host_dirspec[len - 1] == '/') - { - new_host_dirspec[len - 1] = 0; - len--; - } - - decc$to_vms (new_host_dirspec, translate_unix, 1, 2); - strncpy (new_host_dirspec, filename_buff, MAXPATH); - new_host_dirspec [MAXPATH - 1] = (char) 0; - - return new_host_dirspec; -} - -/* Translate a Unix syntax file specification into VMS syntax. - If indicators of VMS syntax found, return input string. */ - -char * -__gnat_to_host_file_spec (char *filespec) -{ - strncpy (new_host_filespec, "", MAXPATH); - if (strchr (filespec, ']') || strchr (filespec, ':')) - { - strncpy (new_host_filespec, filespec, MAXPATH); - } - else - { - decc$to_vms (filespec, translate_unix, 1, 1); - strncpy (new_host_filespec, filename_buff, MAXPATH); - } - - new_host_filespec [MAXPATH - 1] = (char) 0; - - return new_host_filespec; -} - -void -__gnat_adjust_os_resource_limits (void) -{ - SYS$ADJWSL (131072, 0); -} - -#else /* VMS */ - -/* Dummy functions for Osint import for non-VMS systems. */ +/* Dummy functions for Osint import for non-VMS systems. + ??? To be removed. */ int __gnat_to_canonical_file_list_init (char *dirspec ATTRIBUTE_UNUSED, @@ -3665,8 +2807,6 @@ __gnat_adjust_os_resource_limits (void) { } -#endif - #if defined (__mips_vxworks) int _flush_cache (void) @@ -3675,35 +2815,6 @@ _flush_cache (void) } #endif -#if defined (IS_CROSS) \ - || (! ((defined (sparc) || defined (i386)) && defined (sun) \ - && defined (__SVR4)) \ - && ! (defined (linux) && (defined (i386) || defined (__x86_64__))) \ - && ! (defined (linux) && defined (__ia64__)) \ - && ! (defined (linux) && defined (powerpc)) \ - && ! defined (__FreeBSD__) \ - && ! defined (__Lynx__) \ - && ! defined (__hpux__) \ - && ! defined (__APPLE__) \ - && ! defined (_AIX) \ - && ! defined (VMS) \ - && ! defined (__MINGW32__)) - -/* Dummy function to satisfy g-trasym.o. See the preprocessor conditional - just above for a list of native platforms that provide a non-dummy - version of this procedure in libaddr2line.a. */ - -void -convert_addresses (const char *file_name ATTRIBUTE_UNUSED, - void *addrs ATTRIBUTE_UNUSED, - int n_addr ATTRIBUTE_UNUSED, - void *buf ATTRIBUTE_UNUSED, - int *len ATTRIBUTE_UNUSED) -{ - *len = 0; -} -#endif - #if defined (_WIN32) int __gnat_argument_needs_quote = 1; #else @@ -3744,7 +2855,7 @@ int __gnat_copy_attribs (char *from ATTRIBUTE_UNUSED, char *to ATTRIBUTE_UNUSED, int mode ATTRIBUTE_UNUSED) { -#if defined (VMS) || (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \ +#if (defined (__vxworks) && _WRS_VXWORKS_MAJOR < 6) || \ defined (__nucleus__) return -1; @@ -3867,7 +2978,7 @@ __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED, flags |= FD_CLOEXEC; else flags &= ~FD_CLOEXEC; - return fcntl (fd, F_SETFD, flags | FD_CLOEXEC); + return fcntl (fd, F_SETFD, flags); #elif defined(_WIN32) HANDLE h = (HANDLE) _get_osfhandle (fd); if (h == (HANDLE) -1) @@ -3887,11 +2998,7 @@ __gnat_set_close_on_exec (int fd ATTRIBUTE_UNUSED, int __gnat_binder_supports_auto_init (void) { -#ifdef VMS - return 0; -#else - return 1; -#endif + return 1; } /* Indicates that Stand-Alone Libraries are automatically initialized through @@ -3899,7 +3006,7 @@ __gnat_binder_supports_auto_init (void) int __gnat_sals_init_using_constructors (void) { -#if defined (__vxworks) || defined (__Lynx__) || defined (VMS) +#if defined (__vxworks) || defined (__Lynx__) return 0; #else return 1; diff --git a/main/gcc/ada/adaint.h b/main/gcc/ada/adaint.h index 2330a794515..d2a838e53f5 100644 --- a/main/gcc/ada/adaint.h +++ b/main/gcc/ada/adaint.h @@ -53,12 +53,23 @@ extern "C" { #if defined (__GLIBC__) || defined (sun) #define GNAT_FOPEN fopen64 +#define GNAT_OPEN open64 #define GNAT_STAT stat64 #define GNAT_FSTAT fstat64 #define GNAT_LSTAT lstat64 #define GNAT_STRUCT_STAT struct stat64 + +#elif defined(_WIN32) +#define GNAT_FOPEN fopen64 +#define GNAT_OPEN open +#define GNAT_STAT stat64 +#define GNAT_FSTAT fstat64 +#define GNAT_LSTAT lstat +#define GNAT_STRUCT_STAT struct stat64 + #else #define GNAT_FOPEN fopen +#define GNAT_OPEN open #define GNAT_STAT stat #define GNAT_FSTAT fstat #define GNAT_LSTAT lstat @@ -72,6 +83,8 @@ typedef long long OS_Time; typedef long OS_Time; #endif +#define __int64 long long + /* 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 call every time. On other systems this require several system calls. @@ -94,7 +107,7 @@ struct file_attributes { unsigned char directory; OS_Time timestamp; - long file_length; + __int64 file_length; }; /* WARNING: changing the size here might require changing the constant * File_Attributes_Size in osint.ads (which should be big enough to @@ -135,10 +148,10 @@ extern int __gnat_rename (char *, char *); extern int __gnat_chdir (char *); extern int __gnat_rmdir (char *); -extern FILE *__gnat_fopen (char *, char *, int, - char *); +extern FILE *__gnat_fopen (char *, char *, int); extern FILE *__gnat_freopen (char *, char *, FILE *, - int, char *); + int); +extern int __gnat_open (char *, int); extern int __gnat_open_read (char *, int); extern int __gnat_open_rw (char *, int); extern int __gnat_open_create (char *, int); @@ -146,8 +159,9 @@ extern int __gnat_create_output_file (char *); extern int __gnat_create_output_file_new (char *); extern int __gnat_open_append (char *, int); -extern long __gnat_file_length (int); -extern long __gnat_named_file_length (char *); +extern long __gnat_file_length_long (int); +extern __int64 __gnat_file_length (int); +extern __int64 __gnat_named_file_length (char *); extern void __gnat_tmp_name (char *); extern DIR *__gnat_opendir (char *); extern char *__gnat_readdir (DIR *, char *, int *); @@ -172,7 +186,7 @@ extern int __gnat_is_executable_file (char *name); extern void __gnat_reset_attributes (struct file_attributes *); extern int __gnat_error_attributes (struct file_attributes *); -extern long __gnat_file_length_attr (int, char *, struct file_attributes *); +extern __int64 __gnat_file_length_attr (int, char *, struct file_attributes *); extern OS_Time __gnat_file_time_name_attr (char *, struct file_attributes *); extern OS_Time __gnat_file_time_fd_attr (int, struct file_attributes *); extern int __gnat_file_exists_attr (char *, struct file_attributes *); @@ -251,6 +265,10 @@ extern int __gnat_set_close_on_exec (int, int); extern int __gnat_dup (int); extern int __gnat_dup2 (int, int); +/* large file support */ +extern __int64 __gnat_ftell64 (FILE *); +extern int __gnat_fseek64 (FILE *, __int64, int); + extern int __gnat_number_of_cpus (void); extern void __gnat_os_filename (char *, char *, char *, diff --git a/main/gcc/ada/ali.adb b/main/gcc/ada/ali.adb index 73db0e88b50..2fe95525926 100644 --- a/main/gcc/ada/ali.adb +++ b/main/gcc/ada/ali.adb @@ -108,13 +108,13 @@ package body ALI is -- ALI files that are read for a given processing run in gnatbind. Dynamic_Elaboration_Checks_Specified := False; - Float_Format_Specified := ' '; Locking_Policy_Specified := ' '; No_Normalize_Scalars_Specified := False; No_Object_Specified := False; Normalize_Scalars_Specified := False; 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; @@ -875,7 +875,6 @@ package body ALI is First_Sdep => No_Sdep_Id, First_Specific_Dispatching => Specific_Dispatching.Last + 1, First_Unit => No_Unit_Id, - Float_Format => 'I', Last_Interrupt_State => Interrupt_States.Last, Last_Sdep => No_Sdep_Id, Last_Specific_Dispatching => Specific_Dispatching.Last, @@ -892,6 +891,7 @@ package body ALI is Restrictions => No_Restrictions, SAL_Interface => False, Sfile => No_File, + SSO_Default => ' ', Task_Dispatching_Policy => ' ', Time_Slice_Value => -1, WC_Encoding => 'b', @@ -1089,12 +1089,6 @@ package body ALI is ALIs.Table (Id).Partition_Elaboration_Policy := Partition_Elaboration_Policy_Specified; - -- Processing for FD/FG/FI - - elsif C = 'F' then - Float_Format_Specified := Getc; - ALIs.Table (Id).Float_Format := Float_Format_Specified; - -- Processing for Lx elsif C = 'L' then @@ -1131,6 +1125,19 @@ package body ALI is Fatal_Error_Ignore; end if; + -- Processing for OH/OL + + elsif C = 'O' then + C := Getc; + + if C = 'L' or else C = 'H' then + ALIs.Table (Id).SSO_Default := C; + SSO_Default_Specified := True; + + else + Fatal_Error_Ignore; + end if; + -- Processing for Qx elsif C = 'Q' then @@ -2170,20 +2177,30 @@ package body ALI is Notes.Table (Notes.Last).Pragma_Line := Get_Nat; Checkc (':'); Notes.Table (Notes.Last).Pragma_Col := Get_Nat; - Notes.Table (Notes.Last).Unit := Units.Last; + + if not At_Eol and then Nextc = ':' then + Checkc (':'); + Notes.Table (Notes.Last).Pragma_Source_File := + Get_File_Name (Lower => True); + else + Notes.Table (Notes.Last).Pragma_Source_File := + Units.Table (Units.Last).Sfile; + end if; if At_Eol then Notes.Table (Notes.Last).Pragma_Args := No_Name; else + -- Note: can't use Get_Name here as the remainder of the + -- line is unstructured text whose syntax depends on the + -- particular pragma used. + Checkc (' '); Name_Len := 0; while not At_Eol loop Add_Char_To_Name_Buffer (Getc); end loop; - - Notes.Table (Notes.Last).Pragma_Args := Name_Enter; end if; Skip_Eol; diff --git a/main/gcc/ada/ali.ads b/main/gcc/ada/ali.ads index 66a462ed41e..f896e7d0088 100644 --- a/main/gcc/ada/ali.ads +++ b/main/gcc/ada/ali.ads @@ -176,10 +176,6 @@ package ALI is -- always be set as well in this case. Not set if 'P' appears in -- Ignore_Lines. - Float_Format : Character; - -- Set to float format (set to I if no float-format given). Not set if - -- 'P' appears in Ignore_Lines. - No_Object : Boolean; -- Set to True if no object file generated. Not set if 'P' appears in -- Ignore_Lines. @@ -188,6 +184,12 @@ package ALI is -- Set to True if file was compiled with Normalize_Scalars. Not set if -- 'P' appears in Ignore_Lines. + SSO_Default : Character; + -- Set to 'H' or 'L' if file was compiled with a configuration pragma + -- file containing Default_Scalar_Storage_Order (High/Low_Order_First). + -- Set to ' ' if neither pragma was present. Not set if 'P' appears in + -- Ignore_Lines. + Unit_Exception_Table : Boolean; -- Set to True if unit exception table pointer generated. Not set if 'P' -- appears in Ignore_Lines. @@ -463,11 +465,6 @@ package ALI is -- Set to False by Initialize_ALI. Set to True if Scan_ALI reads -- a unit for which dynamic elaboration checking is enabled. - Float_Format_Specified : Character := ' '; - -- Set to blank by Initialize_ALI. Set to appropriate float format - -- character (V or I, see Opt.Float_Format) if an ali file that - -- is read contains an F line setting the floating point format. - Initialize_Scalars_Used : Boolean := False; -- Set True if an ali file contains the Initialize_Scalars flag @@ -501,6 +498,11 @@ package ALI is -- ali files, showing whether a restriction pragma exists anywhere, and -- accumulating the aggregate knowledge of violations. + SSO_Default_Specified : Boolean := False; + -- Set to True if at least one ALI file contains an OH/OL flag indicating + -- that it was compiled with a configuration pragmas file containing the + -- pragma Default_Scalar_Storage_Order (OH/OL present in ALI file P line). + Stack_Check_Switch_Set : Boolean := False; -- Set to True if at least one ALI file contains '-fstack-check' in its -- argument list. @@ -658,8 +660,8 @@ package ALI is Pragma_Col : Nat; -- Column number of pragma - Unit : Unit_Id; - -- Unit_Id for the entry + Pragma_Source_File : File_Name_Type; + -- Source file of pragma Pragma_Args : Name_Id; -- Pragma arguments. No_Name if no arguments, otherwise a single diff --git a/main/gcc/ada/aspects.adb b/main/gcc/ada/aspects.adb index 88bd789b792..82f0c911a67 100644 --- a/main/gcc/ada/aspects.adb +++ b/main/gcc/ada/aspects.adb @@ -509,6 +509,7 @@ package body Aspects is Aspect_Convention => Aspect_Convention, Aspect_CPU => Aspect_CPU, Aspect_Default_Component_Value => Aspect_Default_Component_Value, + Aspect_Default_Initial_Condition => Aspect_Default_Initial_Condition, Aspect_Default_Iterator => Aspect_Default_Iterator, Aspect_Default_Value => Aspect_Default_Value, Aspect_Depends => Aspect_Depends, @@ -543,7 +544,9 @@ package body Aspects is Aspect_Linker_Section => Aspect_Linker_Section, Aspect_Lock_Free => Aspect_Lock_Free, Aspect_Machine_Radix => Aspect_Machine_Radix, + Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, Aspect_No_Return => Aspect_No_Return, + Aspect_Obsolescent => Aspect_Obsolescent, Aspect_Object_Size => Aspect_Object_Size, Aspect_Output => Aspect_Output, Aspect_Pack => Aspect_Pack, diff --git a/main/gcc/ada/aspects.ads b/main/gcc/ada/aspects.ads index bcc22346796..a7477bef66f 100644 --- a/main/gcc/ada/aspects.ads +++ b/main/gcc/ada/aspects.ads @@ -86,6 +86,7 @@ package Aspects is Aspect_Convention, Aspect_CPU, Aspect_Default_Component_Value, + Aspect_Default_Initial_Condition, -- GNAT Aspect_Default_Iterator, Aspect_Default_Value, Aspect_Depends, -- GNAT @@ -108,6 +109,7 @@ package Aspects is Aspect_Linker_Section, -- GNAT Aspect_Machine_Radix, Aspect_Object_Size, -- GNAT + Aspect_Obsolescent, -- GNAT Aspect_Output, Aspect_Part_Of, -- GNAT Aspect_Post, @@ -145,6 +147,7 @@ package Aspects is Aspect_All_Calls_Remote, Aspect_Elaborate_Body, + Aspect_No_Elaboration_Code_All, -- GNAT Aspect_Preelaborate, Aspect_Pure, Aspect_Remote_Call_Interface, @@ -194,7 +197,7 @@ package Aspects is Aspect_Volatile_Components, -- Aspects that have a static boolean value but don't correspond to - -- pragmas + -- pragmas with a single argument that it is the entity in question. Aspect_Lock_Free); -- GNAT @@ -295,76 +298,78 @@ package Aspects is -- The following array indicates what argument type is required Aspect_Argument : constant array (Aspect_Id) of Aspect_Expression := - (No_Aspect => Optional_Expression, - Aspect_Abstract_State => Expression, - Aspect_Address => Expression, - Aspect_Alignment => Expression, - Aspect_Annotate => Expression, - Aspect_Attach_Handler => Expression, - Aspect_Bit_Order => Expression, - Aspect_Component_Size => Expression, - Aspect_Constant_Indexing => Name, - Aspect_Contract_Cases => Expression, - Aspect_Convention => Name, - Aspect_CPU => Expression, - Aspect_Default_Component_Value => Expression, - Aspect_Default_Iterator => Name, - Aspect_Default_Value => Expression, - Aspect_Depends => Expression, - Aspect_Dimension => Expression, - Aspect_Dimension_System => Expression, - Aspect_Dispatching_Domain => Expression, - Aspect_Dynamic_Predicate => Expression, - Aspect_External_Name => Expression, - Aspect_External_Tag => Expression, - Aspect_Global => Expression, - Aspect_Implicit_Dereference => Name, - Aspect_Initial_Condition => Expression, - Aspect_Initializes => Expression, - Aspect_Input => Name, - Aspect_Interrupt_Priority => Expression, - Aspect_Invariant => Expression, - Aspect_Iterable => Expression, - Aspect_Iterator_Element => Name, - Aspect_Link_Name => Expression, - Aspect_Linker_Section => Expression, - Aspect_Machine_Radix => Expression, - Aspect_Object_Size => Expression, - Aspect_Output => Name, - Aspect_Part_Of => Expression, - Aspect_Post => Expression, - Aspect_Postcondition => Expression, - Aspect_Pre => Expression, - Aspect_Precondition => Expression, - Aspect_Predicate => Expression, - Aspect_Priority => Expression, - Aspect_Read => Name, - Aspect_Refined_Depends => Expression, - Aspect_Refined_Global => Expression, - Aspect_Refined_Post => Expression, - Aspect_Refined_State => Expression, - Aspect_Relative_Deadline => Expression, - Aspect_Scalar_Storage_Order => Expression, - Aspect_Simple_Storage_Pool => Name, - Aspect_Size => Expression, - Aspect_Small => Expression, - Aspect_SPARK_Mode => Optional_Name, - Aspect_Static_Predicate => Expression, - Aspect_Storage_Pool => Name, - Aspect_Storage_Size => Expression, - Aspect_Stream_Size => Expression, - Aspect_Suppress => Name, - Aspect_Synchronization => Name, - Aspect_Test_Case => Expression, - Aspect_Type_Invariant => Expression, - Aspect_Unsuppress => Name, - Aspect_Value_Size => Expression, - Aspect_Variable_Indexing => Name, - Aspect_Warnings => Name, - Aspect_Write => Name, - - Boolean_Aspects => Optional_Expression, - Library_Unit_Aspects => Optional_Expression); + (No_Aspect => Optional_Expression, + Aspect_Abstract_State => Expression, + Aspect_Address => Expression, + Aspect_Alignment => Expression, + Aspect_Annotate => Expression, + Aspect_Attach_Handler => Expression, + Aspect_Bit_Order => Expression, + Aspect_Component_Size => Expression, + Aspect_Constant_Indexing => Name, + Aspect_Contract_Cases => Expression, + Aspect_Convention => Name, + Aspect_CPU => Expression, + Aspect_Default_Component_Value => Expression, + Aspect_Default_Initial_Condition => Optional_Expression, + Aspect_Default_Iterator => Name, + Aspect_Default_Value => Expression, + Aspect_Depends => Expression, + Aspect_Dimension => Expression, + Aspect_Dimension_System => Expression, + Aspect_Dispatching_Domain => Expression, + Aspect_Dynamic_Predicate => Expression, + Aspect_External_Name => Expression, + Aspect_External_Tag => Expression, + Aspect_Global => Expression, + Aspect_Implicit_Dereference => Name, + Aspect_Initial_Condition => Expression, + Aspect_Initializes => Expression, + Aspect_Input => Name, + Aspect_Interrupt_Priority => Expression, + Aspect_Invariant => Expression, + Aspect_Iterable => Expression, + Aspect_Iterator_Element => Name, + Aspect_Link_Name => Expression, + Aspect_Linker_Section => Expression, + Aspect_Machine_Radix => Expression, + Aspect_Object_Size => Expression, + Aspect_Obsolescent => Optional_Expression, + Aspect_Output => Name, + Aspect_Part_Of => Expression, + Aspect_Post => Expression, + Aspect_Postcondition => Expression, + Aspect_Pre => Expression, + Aspect_Precondition => Expression, + Aspect_Predicate => Expression, + Aspect_Priority => Expression, + Aspect_Read => Name, + Aspect_Refined_Depends => Expression, + Aspect_Refined_Global => Expression, + Aspect_Refined_Post => Expression, + Aspect_Refined_State => Expression, + Aspect_Relative_Deadline => Expression, + Aspect_Scalar_Storage_Order => Expression, + Aspect_Simple_Storage_Pool => Name, + Aspect_Size => Expression, + Aspect_Small => Expression, + Aspect_SPARK_Mode => Optional_Name, + Aspect_Static_Predicate => Expression, + Aspect_Storage_Pool => Name, + Aspect_Storage_Size => Expression, + Aspect_Stream_Size => Expression, + Aspect_Suppress => Name, + Aspect_Synchronization => Name, + Aspect_Test_Case => Expression, + Aspect_Type_Invariant => Expression, + Aspect_Unsuppress => Name, + Aspect_Value_Size => Expression, + Aspect_Variable_Indexing => Name, + Aspect_Warnings => Name, + Aspect_Write => Name, + + Boolean_Aspects => Optional_Expression, + Library_Unit_Aspects => Optional_Expression); ----------------------------------------- -- Table Linking Names and Aspect_Id's -- @@ -391,9 +396,10 @@ package Aspects is Aspect_Contract_Cases => Name_Contract_Cases, Aspect_Convention => Name_Convention, Aspect_CPU => Name_CPU, + Aspect_Default_Component_Value => Name_Default_Component_Value, + Aspect_Default_Initial_Condition => Name_Default_Initial_Condition, Aspect_Default_Iterator => Name_Default_Iterator, Aspect_Default_Value => Name_Default_Value, - Aspect_Default_Component_Value => Name_Default_Component_Value, Aspect_Depends => Name_Depends, Aspect_Dimension => Name_Dimension, Aspect_Dimension_System => Name_Dimension_System, @@ -426,8 +432,10 @@ package Aspects is Aspect_Linker_Section => Name_Linker_Section, Aspect_Lock_Free => Name_Lock_Free, Aspect_Machine_Radix => Name_Machine_Radix, + Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All, Aspect_No_Return => Name_No_Return, Aspect_Object_Size => Name_Object_Size, + Aspect_Obsolescent => Name_Obsolescent, Aspect_Output => Name_Output, Aspect_Pack => Name_Pack, Aspect_Part_Of => Name_Part_Of, @@ -543,6 +551,14 @@ package Aspects is -- information from the parent type, which must be frozen at that point -- (since freezing the derived type first freezes the parent type). + -- SPARK 2014 aspects do not follow the general delay mechanism as they + -- act as annotations and cannot modify the attributes of their related + -- constructs. To handle forward references in such aspects, the compiler + -- delays the analysis of their respective pragmas by collecting them in + -- N_Contract nodes. The pragmas are then analyzed at the end of the + -- declarative region which contains the related construct. For details, + -- see routines Analyze_xxx_In_Decl_Part. + -- The following shows which aspects are delayed. There are three cases: type Delay_Type is @@ -590,36 +606,27 @@ package Aspects is (No_Aspect => Always_Delay, Aspect_Address => Always_Delay, Aspect_All_Calls_Remote => Always_Delay, - Aspect_Async_Readers => Always_Delay, - Aspect_Async_Writers => Always_Delay, Aspect_Asynchronous => Always_Delay, Aspect_Attach_Handler => Always_Delay, Aspect_Constant_Indexing => Always_Delay, - Aspect_Contract_Cases => Always_Delay, Aspect_CPU => Always_Delay, Aspect_Default_Iterator => Always_Delay, Aspect_Default_Value => Always_Delay, Aspect_Default_Component_Value => Always_Delay, - Aspect_Depends => Always_Delay, Aspect_Discard_Names => Always_Delay, Aspect_Dispatching_Domain => Always_Delay, Aspect_Dynamic_Predicate => Always_Delay, - Aspect_Effective_Reads => Always_Delay, - Aspect_Effective_Writes => Always_Delay, Aspect_Elaborate_Body => Always_Delay, Aspect_External_Name => Always_Delay, Aspect_External_Tag => Always_Delay, Aspect_Export => Always_Delay, Aspect_Favor_Top_Level => Always_Delay, - Aspect_Global => Always_Delay, Aspect_Implicit_Dereference => Always_Delay, Aspect_Import => Always_Delay, Aspect_Independent => Always_Delay, Aspect_Independent_Components => Always_Delay, Aspect_Inline => Always_Delay, Aspect_Inline_Always => Always_Delay, - Aspect_Initial_Condition => Always_Delay, - Aspect_Initializes => Always_Delay, Aspect_Input => Always_Delay, Aspect_Interrupt_Handler => Always_Delay, Aspect_Interrupt_Priority => Always_Delay, @@ -643,9 +650,6 @@ package Aspects is Aspect_Pure => Always_Delay, Aspect_Pure_Function => Always_Delay, Aspect_Read => Always_Delay, - Aspect_Refined_Depends => Always_Delay, - Aspect_Refined_Global => Always_Delay, - Aspect_Refined_State => Always_Delay, Aspect_Relative_Deadline => Always_Delay, Aspect_Remote_Access_Type => Always_Delay, Aspect_Remote_Call_Interface => Always_Delay, @@ -673,11 +677,26 @@ package Aspects is Aspect_Abstract_State => Never_Delay, Aspect_Annotate => Never_Delay, + Aspect_Async_Readers => Never_Delay, + Aspect_Async_Writers => Never_Delay, + Aspect_Contract_Cases => Never_Delay, Aspect_Convention => Never_Delay, + Aspect_Default_Initial_Condition => Never_Delay, + Aspect_Depends => Never_Delay, Aspect_Dimension => Never_Delay, Aspect_Dimension_System => Never_Delay, + Aspect_Effective_Reads => Never_Delay, + Aspect_Effective_Writes => Never_Delay, + Aspect_Global => Never_Delay, + Aspect_Initial_Condition => Never_Delay, + Aspect_Initializes => Never_Delay, + Aspect_No_Elaboration_Code_All => Never_Delay, + Aspect_Obsolescent => Never_Delay, Aspect_Part_Of => Never_Delay, + Aspect_Refined_Depends => Never_Delay, + Aspect_Refined_Global => Never_Delay, Aspect_Refined_Post => Never_Delay, + Aspect_Refined_State => Never_Delay, Aspect_SPARK_Mode => Never_Delay, Aspect_Synchronization => Never_Delay, Aspect_Test_Case => Never_Delay, diff --git a/main/gcc/ada/atree.adb b/main/gcc/ada/atree.adb index 19517734867..2af7e2e48b9 100644 --- a/main/gcc/ada/atree.adb +++ b/main/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1800,18 +1800,17 @@ package body Atree is New_Node := New_Copy (Source); Fix_Parents (Ref_Node => Source, Fix_Node => New_Node); - -- We now set the parent of the new node to be the same as the - -- parent of the source. Almost always this parent will be - -- replaced by a new value when the relocated node is reattached - -- to the tree, but by doing it now, we ensure that this node is - -- not even temporarily disconnected from the tree. Note that this - -- does not happen free, because in the list case, the parent does - -- not get set. + -- We now set the parent of the new node to be the same as the parent of + -- the source. Almost always this parent will be replaced by a new value + -- when the relocated node is reattached to the tree, but by doing it + -- now, we ensure that this node is not even temporarily disconnected + -- from the tree. Note that this does not happen free, because in the + -- list case, the parent does not get set. Set_Parent (New_Node, Parent (Source)); - -- If the node being relocated was a rewriting of some original - -- node, then the relocated node has the same original node. + -- If the node being relocated was a rewriting of some original node, + -- then the relocated node has the same original node. if Orig_Nodes.Table (Source) /= Source then Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source); diff --git a/main/gcc/ada/atree.ads b/main/gcc/ada/atree.ads index 38491d2b8ea..37b276e9cdb 100644 --- a/main/gcc/ada/atree.ads +++ b/main/gcc/ada/atree.ads @@ -313,7 +313,12 @@ package Atree is Warnings_Detected : Nat := 0; -- Number of warnings detected. Initialized to zero at the start of - -- compilation. Initialized for -gnatVa use, see comment above. + -- compilation. Initialized for -gnatVa use, see comment above. This + -- count includes the count of style and info messages. + + Info_Messages : Nat := 0; + -- Number of info messages generated. Info messages are neved treated as + -- errors (whether from use of the pragma, or the compiler switch -gnatwe). Warnings_Treated_As_Errors : Nat := 0; -- Number of warnings changed into errors as a result of matching a pattern diff --git a/main/gcc/ada/back_end.adb b/main/gcc/ada/back_end.adb index 1d5de114e24..3e535547db6 100644 --- a/main/gcc/ada/back_end.adb +++ b/main/gcc/ada/back_end.adb @@ -126,7 +126,8 @@ package body Back_End is Nat (Physical_To_Logical (Last_Source_Line (J), J)); end loop; - -- Deal with case of generating SCIL, we should not be here! + -- Deal with case of generating SCIL, we should not be here unless + -- debugging CodePeer mode in GNAT. if Generate_SCIL then Error_Msg_N ("'S'C'I'L generation not available", Cunit (Main_Unit)); @@ -139,6 +140,14 @@ package body Back_End is end if; end if; + -- We should be here in GNATprove mode only when debugging GNAT. Do not + -- call gigi in that case, as it is not prepared to handle the special + -- form of the tree obtained in GNATprove mode. + + if GNATprove_Mode then + return; + end if; + -- The actual call to the back end gigi diff --git a/main/gcc/ada/bcheck.adb b/main/gcc/ada/bcheck.adb index 0e81ee650e9..be48f06fecf 100644 --- a/main/gcc/ada/bcheck.adb +++ b/main/gcc/ada/bcheck.adb @@ -47,7 +47,6 @@ package body Bcheck is procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dynamic_Elaboration_Checking; - procedure Check_Consistent_Floating_Point_Format; procedure Check_Consistent_Interrupt_States; procedure Check_Consistent_Locking_Policy; procedure Check_Consistent_Normalize_Scalars; @@ -56,6 +55,7 @@ package body Bcheck is procedure Check_Consistent_Queuing_Policy; procedure Check_Consistent_Restrictions; procedure Check_Consistent_Restriction_No_Default_Initialization; + procedure Check_Consistent_SSO_Default; procedure Check_Consistent_Zero_Cost_Exception_Handling; procedure Consistency_Error_Msg (Msg : String); @@ -72,10 +72,6 @@ package body Bcheck is procedure Check_Configuration_Consistency is begin - if Float_Format_Specified /= ' ' then - Check_Consistent_Floating_Point_Format; - end if; - if Queuing_Policy_Specified /= ' ' then Check_Consistent_Queuing_Policy; end if; @@ -88,6 +84,10 @@ package body Bcheck is Check_Consistent_Partition_Elaboration_Policy; end if; + if SSO_Default_Specified then + Check_Consistent_SSO_Default; + end if; + if Zero_Cost_Exceptions_Specified then Check_Consistent_Zero_Cost_Exception_Handling; end if; @@ -521,41 +521,6 @@ package body Bcheck is end if; end Check_Consistent_Dynamic_Elaboration_Checking; - -------------------------------------------- - -- Check_Consistent_Floating_Point_Format -- - -------------------------------------------- - - -- The rule is that all files must be compiled with the same setting - -- for the floating-point format. - - procedure Check_Consistent_Floating_Point_Format is - begin - -- First search for a unit specifying a floating-point format and then - -- check all remaining units against it. - - Find_Format : for A1 in ALIs.First .. ALIs.Last loop - if ALIs.Table (A1).Float_Format /= ' ' then - Check_Format : declare - Format : constant Character := ALIs.Table (A1).Float_Format; - begin - for A2 in A1 + 1 .. ALIs.Last loop - if ALIs.Table (A2).Float_Format /= Format then - Error_Msg_File_1 := ALIs.Table (A1).Sfile; - Error_Msg_File_2 := ALIs.Table (A2).Sfile; - - Consistency_Error_Msg - ("{ and { compiled with different " & - "floating-point representations"); - exit Find_Format; - end if; - end loop; - end Check_Format; - - exit Find_Format; - end if; - end loop Find_Format; - end Check_Consistent_Floating_Point_Format; - --------------------------------------- -- Check_Consistent_Interrupt_States -- --------------------------------------- @@ -1108,6 +1073,73 @@ package body Bcheck is end loop; end Check_Consistent_Restriction_No_Default_Initialization; + ---------------------------------- + -- Check_Consistent_SSO_Default -- + ---------------------------------- + + procedure Check_Consistent_SSO_Default is + Default : Character; + + begin + Default := ALIs.Table (ALIs.First).SSO_Default; + + -- Check all entries match the default above from the first entry + + for A1 in ALIs.First + 1 .. ALIs.Last loop + if ALIs.Table (A1).SSO_Default /= Default then + Default := '?'; + exit; + end if; + end loop; + + -- All match, return + + if Default /= '?' then + return; + end if; + + -- Here we have a mismatch + + Consistency_Error_Msg + ("files not compiled with same Default_Scalar_Storage_Order"); + + Write_Eol; + Write_Str ("files compiled with High_Order_First"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).SSO_Default = 'H' then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + + Write_Eol; + Write_Str ("files compiled with Low_Order_First"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).SSO_Default = 'L' then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + + Write_Eol; + Write_Str ("files compiled with no Default_Scalar_Storage_Order"); + Write_Eol; + + for A1 in ALIs.First .. ALIs.Last loop + if ALIs.Table (A1).SSO_Default = ' ' then + Write_Str (" "); + Write_Name (ALIs.Table (A1).Sfile); + Write_Eol; + end if; + end loop; + end Check_Consistent_SSO_Default; + --------------------------------------------------- -- Check_Consistent_Zero_Cost_Exception_Handling -- --------------------------------------------------- diff --git a/main/gcc/ada/binde.adb b/main/gcc/ada/binde.adb index 935e09e9d73..6c43ab8fdf9 100644 --- a/main/gcc/ada/binde.adb +++ b/main/gcc/ada/binde.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Namet; use Namet; with Opt; use Opt; with Osint; with Output; use Output; -with Targparm; use Targparm; with System.Case_Util; use System.Case_Util; @@ -1086,15 +1085,9 @@ package body Binde is -- 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 - if OpenVMS_On_Target then - Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable"); - else - Error_Msg ("?use of -p switch questionable"); - end if; - + Error_Msg ("?use of -p switch questionable"); Error_Msg ("?since all units compiled with static elaboration model"); end if; @@ -1111,7 +1104,6 @@ package body Binde is -- 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; @@ -1222,8 +1214,7 @@ package body Binde is -- 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) diff --git a/main/gcc/ada/binderr.ads b/main/gcc/ada/binderr.ads index 3a419d5d697..46b1846e0ed 100644 --- a/main/gcc/ada/binderr.ads +++ b/main/gcc/ada/binderr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +59,7 @@ package Binderr is -- specified by the File_Name_Type value stored in Error_Msg_File_2. -- Insertion character $ (Dollar: insert unit name from Names table) - -- The character & is replaced by the text for the unit name specified + -- The character $ is replaced by the text for the unit name specified -- by the Name_Id value stored in Error_Msg_Unit_1. The name is always -- enclosed in quotes. A second $ may appear in a single message in -- which case it is similarly replaced by the name which is specified diff --git a/main/gcc/ada/bindgen.adb b/main/gcc/ada/bindgen.adb index f045b8e0235..8979b7736bf 100644 --- a/main/gcc/ada/bindgen.adb +++ b/main/gcc/ada/bindgen.adb @@ -52,10 +52,6 @@ package body Bindgen is Last : Natural := 0; -- Last location in Statement_Buffer currently set - With_DECGNAT : Boolean := False; - -- Flag which indicates whether the program uses the DECGNAT library - -- (presence of the unit DEC). - With_GNARL : Boolean := False; -- Flag which indicates whether the program uses the GNARL library -- (presence of the unit System.OS_Interface) @@ -163,13 +159,6 @@ package body Bindgen is -- A value of zero indicates that time slicing should be suppressed. If no -- pragma is present, and no -T switch was used, the value is -1. - -- Heap_Size is the heap to use for memory allocations set by use of a - -- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical. - -- Valid values are 32 and 64. This switch is only effective on VMS. - - -- Float_Format is the float representation in use. Valid values are - -- 'I' for IEEE and 'V' for VAX Float. This is only for VMS. - -- WC_Encoding shows the wide character encoding method used for the main -- program. This is one of the encoding letters defined in -- System.WCh_Con.WC_Encoding_Letters. @@ -325,18 +314,16 @@ package body Bindgen is -- Move routine for sorting linker options procedure Resolve_Binder_Options; - -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS - -- since it tests for a package named "dec" which might cause a conflict - -- on non-VMS systems. + -- 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. 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. + -- 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. procedure Set_Boolean (B : Boolean); -- Set given boolean value in Statement_Buffer at the Last + 1 position @@ -346,9 +333,9 @@ package body Bindgen is -- Initializes contents of IS_Pragma_Settings table from ALI table 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. + -- 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. procedure Set_Name_Buffer; -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer @@ -361,9 +348,9 @@ package body Bindgen is -- 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 characters of S. The caller must ensure that these characters do - -- in fact exist in the Statement_Buffer. + -- Replaces the last S'Length characters in the Statement_Buffer with the + -- characters of S. The caller must ensure that these characters do in fact + -- exist in the Statement_Buffer. type Qualification_Mode is (Dollar_Sign, Dot, Double_Underscores); @@ -374,9 +361,9 @@ package body Bindgen is -- underscores (__), a dollar sign ($) or left as is. procedure Set_Unit_Number (U : Unit_Id); - -- Sets unit number (first unit is 1, leading zeroes output to line - -- up all output unit numbers nicely as required by the value, and - -- by the total number of units. + -- Sets unit number (first unit is 1, leading zeroes output to line up all + -- output unit numbers nicely as required by the value, and by the total + -- number of units. procedure Write_Statement_Buffer; -- Write out contents of statement buffer up to Last, and reset Last to 0 @@ -659,36 +646,6 @@ package body Bindgen is """__gnat_finalize_library_objects"");"); end if; - -- Import entry point for environment feature enable/disable - -- routine, and indication that it's been called previously. - - if OpenVMS_On_Target then - WBI (""); - WBI (" procedure Set_Features;"); - WBI (" pragma Import (C, Set_Features, " & - """__gnat_set_features"");"); - WBI (""); - WBI (" Features_Set : Integer;"); - WBI (" pragma Import (C, Features_Set, " & - """__gnat_features_set"");"); - - if Opt.Heap_Size /= 0 then - WBI (""); - WBI (" Heap_Size : Integer;"); - WBI (" pragma Import (C, Heap_Size, " & - """__gl_heap_size"");"); - - Write_Statement_Buffer; - end if; - - WBI (""); - WBI (" Float_Format : Character;"); - WBI (" pragma Import (C, Float_Format, " & - """__gl_float_format"");"); - - 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. @@ -886,44 +843,6 @@ package body Bindgen is WBI (" Install_Handler;"); WBI (" end if;"); end if; - - -- Generate call to Set_Features - - if OpenVMS_On_Target then - - -- Set_Features will call IEEE$SET_FP_CONTROL appropriately - -- depending on the setting of Float_Format. - - WBI (""); - Set_String (" Float_Format := '"); - - if Float_Format_Specified = 'G' - or else - Float_Format_Specified = 'D' - then - Set_Char ('V'); - else - Set_Char ('I'); - end if; - - Set_String ("';"); - Write_Statement_Buffer; - - WBI (""); - WBI (" if Features_Set = 0 then"); - WBI (" Set_Features;"); - WBI (" end if;"); - - -- Features_Set may twiddle the heap size according to a logical - -- name, but the binder switch must override. - - if Opt.Heap_Size /= 0 then - Set_String (" Heap_Size := "); - Set_Int (Opt.Heap_Size); - Set_Char (';'); - Write_Statement_Buffer; - end if; - end if; end if; -- Generate call to set Initialize_Scalar values if active @@ -2120,10 +2039,10 @@ package body Bindgen is -- files. The reason for this decision is that libraries referenced -- by internal routines may reference these standard library entries. - -- Note that we do not insert anything when pragma No_Run_Time has been - -- specified or when the standard libraries are not to be used, - -- otherwise on some platforms, such as VMS, we may get duplicate - -- symbols when linking. + -- Note that we do not insert anything when pragma No_Run_Time has + -- been specified or when the standard libraries are not to be used, + -- otherwise on some platforms, we may get duplicate symbols when + -- linking (not clear if this is still the case, but it is harmless). if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then Name_Len := 0; @@ -2138,18 +2057,6 @@ package body Bindgen is WBI (" -- " & Name_Buffer (1 .. Name_Len)); - if With_DECGNAT then - Name_Len := 0; - - if Opt.Shared_Libgnat then - Add_Str_To_Name_Buffer (Shared_Lib ("decgnat")); - else - Add_Str_To_Name_Buffer ("-ldecgnat"); - end if; - - Write_Linker_Option; - end if; - if With_GNARL then Name_Len := 0; @@ -2298,8 +2205,7 @@ package body Bindgen is Resolve_Binder_Options; - -- Usually, adafinal is called using a pragma Import C. Since Import C - -- doesn't have the same semantics for VMs or CodePeer use standard Ada. + -- Generate standard with's if not Suppress_Standard_Library_On_Target then if CodePeer_Mode then @@ -2493,6 +2399,14 @@ package body Bindgen is ", Body_File_Name => """ & Name_Buffer (1 .. Name_Len + 3)); + -- Generate pragma Suppress (Overflow_Check). This is needed for recent + -- versions of the compiler which have overflow checks on by default. + -- We do not want overflow checking enabled for the increments of the + -- elaboration variables (since this can cause an unwanted reference to + -- the last chance exception handler for limited run-times). + + WBI ("pragma Suppress (Overflow_Check);"); + -- Generate with of System.Restrictions to initialize -- Run_Time_Restrictions. @@ -3017,12 +2931,6 @@ package body Bindgen is Check_Package (With_GNARL, "system.os_interface%s"); - -- Ditto for declib and the "dec" package - - if OpenVMS_On_Target then - Check_Package (With_DECGNAT, "dec%s"); - end if; - -- Ditto for the use of restricted tasking Check_Package diff --git a/main/gcc/ada/bindusg.adb b/main/gcc/ada/bindusg.adb index e9d39504af1..b1029487dfa 100644 --- a/main/gcc/ada/bindusg.adb +++ b/main/gcc/ada/bindusg.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +120,6 @@ package body Bindusg is Write_Line (" -h Output this usage (help) information"); - -- Line for -H switch - - Write_Line (" -Hnn Use nn bit heap where nn is 32 or 64 " & - "(VMS Only)"); - -- Lines for -I switch Write_Line (" -Idir Specify library and source files search path"); diff --git a/main/gcc/ada/butil.adb b/main/gcc/ada/butil.adb index 703d2439530..3ac112a07a5 100644 --- a/main/gcc/ada/butil.adb +++ b/main/gcc/ada/butil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Output; use Output; -with Targparm; use Targparm; +with Output; use Output; package body Butil is @@ -38,17 +37,9 @@ package body Butil is function Is_Internal_Unit return Boolean is begin return Is_Predefined_Unit - or else (Name_Len > 4 - and then (Name_Buffer (1 .. 5) = "gnat%" - or else - Name_Buffer (1 .. 5) = "gnat.")) - or else - (OpenVMS_On_Target - and then Name_Len > 3 - and then (Name_Buffer (1 .. 4) = "dec%" - or else - Name_Buffer (1 .. 4) = "dec.")); - + or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%" + or else + Name_Buffer (1 .. 5) = "gnat.")); end Is_Internal_Unit; ------------------------ @@ -59,54 +50,25 @@ package body Butil is -- is that it would drag too much junk into the binder. function Is_Predefined_Unit return Boolean is + L : Natural renames Name_Len; + B : String renames Name_Buffer; begin - return (Name_Len > 3 - and then Name_Buffer (1 .. 4) = "ada.") - - or else (Name_Len > 6 - and then Name_Buffer (1 .. 7) = "system.") - - or else (Name_Len > 10 - and then Name_Buffer (1 .. 11) = "interfaces.") - - or else (Name_Len > 3 - and then Name_Buffer (1 .. 4) = "ada%") - - or else (Name_Len > 8 - and then Name_Buffer (1 .. 9) = "calendar%") - - or else (Name_Len > 9 - and then Name_Buffer (1 .. 10) = "direct_io%") - - or else (Name_Len > 10 - and then Name_Buffer (1 .. 11) = "interfaces%") - - or else (Name_Len > 13 - and then Name_Buffer (1 .. 14) = "io_exceptions%") - - or else (Name_Len > 12 - and then Name_Buffer (1 .. 13) = "machine_code%") - - or else (Name_Len > 13 - and then Name_Buffer (1 .. 14) = "sequential_io%") - - or else (Name_Len > 6 - and then Name_Buffer (1 .. 7) = "system%") - - or else (Name_Len > 7 - and then Name_Buffer (1 .. 8) = "text_io%") - - or else (Name_Len > 20 - and then Name_Buffer (1 .. 21) = "unchecked_conversion%") - - or else (Name_Len > 22 - and then Name_Buffer (1 .. 23) = "unchecked_deallocation%") - - or else (Name_Len > 4 - and then Name_Buffer (1 .. 5) = "gnat%") - - or else (Name_Len > 4 - and then Name_Buffer (1 .. 5) = "gnat."); + return (L > 3 and then B (1 .. 4) = "ada.") + or else (L > 6 and then B (1 .. 7) = "system.") + or else (L > 10 and then B (1 .. 11) = "interfaces.") + or else (L > 3 and then B (1 .. 4) = "ada%") + or else (L > 8 and then B (1 .. 9) = "calendar%") + or else (L > 9 and then B (1 .. 10) = "direct_io%") + or else (L > 10 and then B (1 .. 11) = "interfaces%") + or else (L > 13 and then B (1 .. 14) = "io_exceptions%") + or else (L > 12 and then B (1 .. 13) = "machine_code%") + or else (L > 13 and then B (1 .. 14) = "sequential_io%") + or else (L > 6 and then B (1 .. 7) = "system%") + or else (L > 7 and then B (1 .. 8) = "text_io%") + or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%") + or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%") + or else (L > 4 and then B (1 .. 5) = "gnat%") + or else (L > 4 and then B (1 .. 5) = "gnat."); end Is_Predefined_Unit; ---------------- @@ -119,7 +81,7 @@ package body Butil is declare U1_Name : constant String (1 .. Name_Len) := - Name_Buffer (1 .. Name_Len); + Name_Buffer (1 .. Name_Len); Min_Length : Natural; begin @@ -131,10 +93,10 @@ package body Butil is Min_Length := U1_Name'Last; end if; - for I in 1 .. Min_Length loop - if U1_Name (I) > Name_Buffer (I) then + for J in 1 .. Min_Length loop + if U1_Name (J) > Name_Buffer (J) then return False; - elsif U1_Name (I) < Name_Buffer (I) then + elsif U1_Name (J) < Name_Buffer (J) then return True; end if; end loop; diff --git a/main/gcc/ada/cal.c b/main/gcc/ada/cal.c index 6eb17691581..14921dcf440 100644 --- a/main/gcc/ada/cal.c +++ b/main/gcc/ada/cal.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2009, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, Free Software Foundation, Inc. * * * * GNAT is 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,27 +35,11 @@ /* struct timeval fields type are not normalized (they are generally */ /* defined as int or long values). */ -#if defined(VMS) || defined(__nucleus__) - -/* this is temporary code to avoid build failure under VMS */ - -void -__gnat_timeval_to_duration (void *t, long *sec, long *usec) -{ -} - -void -__gnat_duration_to_timeval (long sec, long usec, void *t) -{ -} - -#else - #if defined (__vxworks) #ifdef __RTP__ #include #include -#if (_WRS_VXWORKS_MINOR != 0) +#if (_WRS_VXWORKS_MAJOR == 7) || (_WRS_VXWORKS_MINOR != 0) #include #endif #else @@ -75,35 +59,18 @@ __gnat_duration_to_timeval (long sec, long usec, void *t) #endif void -__gnat_timeval_to_duration (struct timeval *t, long *sec, long *usec) +__gnat_timeval_to_duration (struct timeval *t, long long *sec, long *usec) { - *sec = (long) t->tv_sec; + *sec = (long long) t->tv_sec; *usec = (long) t->tv_usec; } void -__gnat_duration_to_timeval (long sec, long usec, struct timeval *t) +__gnat_duration_to_timeval (long long sec, long usec, struct timeval *t) { - /* here we are doing implicit conversion from a long to the struct timeval + /* here we are doing implicit conversion to the struct timeval fields types. */ t->tv_sec = sec; t->tv_usec = usec; } -#endif - -#ifdef __alpha_vxworks -#include "vxWorks.h" -#elif defined (__vxworks) -#include -#endif - -/* Return the value of the "time" C library function. We always return - a long and do it this way to avoid problems with not knowing - what time_t is on the target. */ - -long -gnat_time (void) -{ - return time (0); -} diff --git a/main/gcc/ada/checks.adb b/main/gcc/ada/checks.adb index d055306edd1..05f4b7e476a 100644 --- a/main/gcc/ada/checks.adb +++ b/main/gcc/ada/checks.adb @@ -61,7 +61,6 @@ with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; -with Urealp; use Urealp; with Validsw; use Validsw; package body Checks is @@ -389,11 +388,49 @@ package body Checks is ----------------------------- procedure Activate_Overflow_Check (N : Node_Id) is + Typ : constant Entity_Id := Etype (N); + begin - if not Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then - Set_Do_Overflow_Check (N, True); - Possible_Local_Raise (N, Standard_Constraint_Error); + -- Floating-point case. If Etype is not set (this can happen when we + -- activate a check on a node that has not yet been analyzed), then + -- we assume we do not have a floating-point type (as per our spec). + + if Present (Typ) and then Is_Floating_Point_Type (Typ) then + + -- Ignore call if we have no automatic overflow checks on the target + -- and Check_Float_Overflow mode is not set. These are the cases in + -- which we expect to generate infinities and NaN's with no check. + + if not (Machine_Overflows_On_Target or Check_Float_Overflow) then + return; + + -- Ignore for unary operations ("+", "-", abs) since these can never + -- result in overflow for floating-point cases. + + elsif Nkind (N) in N_Unary_Op then + return; + + -- Otherwise we will set the flag + + else + null; + end if; + + -- Discrete case + + else + -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check + -- for zero-divide is a divide check, not an overflow check). + + if Nkind_In (N, N_Op_Rem, N_Op_Mod, N_Op_Plus) then + return; + end if; end if; + + -- Fall through for cases where we do set the flag + + Set_Do_Overflow_Check (N, True); + Possible_Local_Raise (N, Standard_Constraint_Error); end Activate_Overflow_Check; -------------------------- @@ -1796,6 +1833,8 @@ package body Checks is if Do_Overflow_Check (N) and then not Overflow_Checks_Suppressed (Etype (N)) then + Set_Do_Overflow_Check (N, False); + -- Test for extremely annoying case of xxx'First divided by -1 -- for division of signed integer types (only overflow case). @@ -1856,6 +1895,8 @@ package body Checks is -- it is a Division_Check and not an Overflow_Check. if Do_Division_Check (N) then + Set_Do_Division_Check (N, False); + if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then Insert_Action (N, Make_Raise_Constraint_Error (Loc, @@ -2402,13 +2443,18 @@ package body Checks is Nam : Name_Id; begin - -- Pick the proper version of 'Valid depending on the type of the - -- context. If the context is not eligible for such a check, return. + -- For scalars, generate 'Valid test if Is_Scalar_Type (Typ) then Nam := Name_Valid; - elsif not No_Scalar_Parts (Typ) then + + -- For any non-scalar with scalar parts, generate 'Valid_Scalars test + + elsif Scalar_Part_Present (Typ) then Nam := Name_Valid_Scalars; + + -- No test needed for other cases (no scalars to test) + else return; end if; @@ -2842,11 +2888,6 @@ package body Checks is and then not Has_Infinities (Target_Typ) then Enable_Range_Check (Expr); - - -- Always do a range check for operators if option set - - elsif Check_Float_Overflow and then Nkind (Expr) in N_Op then - Enable_Range_Check (Expr); end if; end if; @@ -2930,11 +2971,18 @@ package body Checks is and then Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) and then (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) + + -- Also check if the expression itself is in the range of the + -- target type if it is a known at compile time value. We skip + -- this test if S_Typ is set since for OUT and IN OUT parameters + -- the Expr itself is not relevant to the checking. + or else - Is_In_Range (Expr, Target_Typ, - Assume_Valid => True, - Fixed_Int => Fixed_Int, - Int_Real => Int_Real)) + (No (Source_Typ) + and then Is_In_Range (Expr, Target_Typ, + Assume_Valid => True, + Fixed_Int => Fixed_Int, + Int_Real => Int_Real))) then return; @@ -2955,9 +3003,9 @@ package body Checks is -- 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. Override this decision in Check_Float_Overflow mode. + -- infinities. - if Is_Constrained (S_Typ) or else Check_Float_Overflow then + if Is_Constrained (S_Typ) then Enable_Range_Check (Expr); end if; @@ -4071,18 +4119,20 @@ package body Checks is type Cache_Index is range 0 .. Cache_Size - 1; -- Determine size of below cache (power of 2 is more efficient) - Determine_Range_Cache_N : array (Cache_Index) of Node_Id; - Determine_Range_Cache_V : array (Cache_Index) of Boolean; - Determine_Range_Cache_Lo : array (Cache_Index) of Uint; - Determine_Range_Cache_Hi : array (Cache_Index) of Uint; + Determine_Range_Cache_N : array (Cache_Index) of Node_Id; + Determine_Range_Cache_V : array (Cache_Index) of Boolean; + Determine_Range_Cache_Lo : array (Cache_Index) of Uint; + Determine_Range_Cache_Hi : array (Cache_Index) of Uint; + Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal; + Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal; -- The above arrays are used to implement a small direct cache for - -- Determine_Range calls. Because of the way Determine_Range recursively - -- traces subexpressions, and because overflow checking calls the routine - -- on the way up the tree, a quadratic behavior can otherwise be - -- encountered in large expressions. The cache entry for node N is stored - -- in the (N mod Cache_Size) entry, and can be validated by checking the - -- actual node value stored there. The Range_Cache_V array records the - -- setting of Assume_Valid for the cache entry. + -- Determine_Range and Determine_Range_R calls. Because of the way these + -- subprograms recursively traces subexpressions, and because overflow + -- checking calls the routine on the way up the tree, a quadratic behavior + -- can otherwise be encountered in large expressions. The cache entry for + -- node N is stored in the (N mod Cache_Size) entry, and can be validated + -- by checking the actual node value stored there. The Range_Cache_V array + -- records the setting of Assume_Valid for the cache entry. procedure Determine_Range (N : Node_Id; @@ -4539,7 +4589,7 @@ package body Checks is if OK1 then -- If the refined value of the low bound is greater than the type - -- high bound, then reset it to the more restrictive value. However, + -- low bound, then reset it to the more restrictive value. However, -- we do NOT do this for the case of a modular type where the -- possible upper bound on the value is above the base type high -- bound, because that means the result could wrap. @@ -4591,6 +4641,428 @@ package body Checks is end if; end Determine_Range; + ----------------------- + -- Determine_Range_R -- + ----------------------- + + procedure Determine_Range_R + (N : Node_Id; + OK : out Boolean; + Lo : out Ureal; + Hi : out Ureal; + Assume_Valid : Boolean := False) + is + Typ : Entity_Id := Etype (N); + -- Type to use, may get reset to base type for possibly invalid entity + + Lo_Left : Ureal; + Hi_Left : Ureal; + -- Lo and Hi bounds of left operand + + Lo_Right : Ureal; + Hi_Right : Ureal; + -- Lo and Hi bounds of right (or only) operand + + Bound : Node_Id; + -- Temp variable used to hold a bound node + + Hbound : Ureal; + -- High bound of base type of expression + + Lor : Ureal; + Hir : Ureal; + -- Refined values for low and high bounds, after tightening + + OK1 : Boolean; + -- Used in lower level calls to indicate if call succeeded + + Cindex : Cache_Index; + -- Used to search cache + + Btyp : Entity_Id; + -- Base type + + function OK_Operands return Boolean; + -- Used for binary operators. Determines the ranges of the left and + -- right operands, and if they are both OK, returns True, and puts + -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left. + + function Round_Machine (B : Ureal) return Ureal; + -- B is a real bound. Round it using mode Round_Even. + + ----------------- + -- OK_Operands -- + ----------------- + + function OK_Operands return Boolean is + begin + Determine_Range_R + (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid); + + if not OK1 then + return False; + end if; + + Determine_Range_R + (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); + return OK1; + end OK_Operands; + + ------------------- + -- Round_Machine -- + ------------------- + + function Round_Machine (B : Ureal) return Ureal is + begin + return Machine (Typ, B, Round_Even, N); + end Round_Machine; + + -- Start of processing for Determine_Range_R + + begin + -- Prevent junk warnings by initializing range variables + + Lo := No_Ureal; + Hi := No_Ureal; + Lor := No_Ureal; + Hir := No_Ureal; + + -- For temporary constants internally generated to remove side effects + -- we must use the corresponding expression to determine the range of + -- the expression. But note that the expander can also generate + -- constants in other cases, including deferred constants. + + if Is_Entity_Name (N) + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + and then Ekind (Entity (N)) = E_Constant + and then Is_Internal_Name (Chars (Entity (N))) + then + if Present (Expression (Parent (Entity (N)))) then + Determine_Range_R + (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid); + + elsif Present (Full_View (Entity (N))) then + Determine_Range_R + (Expression (Parent (Full_View (Entity (N)))), + OK, Lo, Hi, Assume_Valid); + + else + OK := False; + end if; + + return; + end if; + + -- If type is not defined, we can't determine its range + + if No (Typ) + + -- We don't deal with anything except IEEE floating-point types + + or else not Is_Floating_Point_Type (Typ) + or else Float_Rep (Typ) /= IEEE_Binary + + -- Ignore type for which an error has been posted, since range in + -- this case may well be a bogosity deriving from the error. Also + -- ignore if error posted on the reference node. + + or else Error_Posted (N) or else Error_Posted (Typ) + then + OK := False; + return; + end if; + + -- For all other cases, we can determine the range + + OK := True; + + -- If value is compile time known, then the possible range is the one + -- value that we know this expression definitely has. + + if Compile_Time_Known_Value (N) then + Lo := Expr_Value_R (N); + Hi := Lo; + return; + end if; + + -- Return if already in the cache + + Cindex := Cache_Index (N mod Cache_Size); + + if Determine_Range_Cache_N (Cindex) = N + and then + Determine_Range_Cache_V (Cindex) = Assume_Valid + then + Lo := Determine_Range_Cache_Lo_R (Cindex); + Hi := Determine_Range_Cache_Hi_R (Cindex); + return; + end if; + + -- Otherwise, start by finding the bounds of the type of the expression, + -- the value cannot be outside this range (if it is, then we have an + -- overflow situation, which is a separate check, we are talking here + -- only about the expression value). + + -- First a check, never try to find the bounds of a generic type, since + -- these bounds are always junk values, and it is only valid to look at + -- the bounds in an instance. + + if Is_Generic_Type (Typ) then + OK := False; + return; + end if; + + -- First step, change to use base type unless we know the value is valid + + if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N))) + or else Assume_No_Invalid_Values + or else Assume_Valid + then + null; + else + Typ := Underlying_Type (Base_Type (Typ)); + end if; + + -- Retrieve the base type. Handle the case where the base type is a + -- private type. + + Btyp := Base_Type (Typ); + + if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then + Btyp := Full_View (Btyp); + end if; + + -- We use the actual bound unless it is dynamic, in which case use the + -- corresponding base type bound if possible. If we can't get a bound + -- then we figure we can't determine the range (a peculiar case, that + -- perhaps cannot happen, but there is no point in bombing in this + -- optimization circuit). + + -- First the low bound + + Bound := Type_Low_Bound (Typ); + + if Compile_Time_Known_Value (Bound) then + Lo := Expr_Value_R (Bound); + + elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then + Lo := Expr_Value_R (Type_Low_Bound (Btyp)); + + else + OK := False; + return; + end if; + + -- Now the high bound + + Bound := Type_High_Bound (Typ); + + -- We need the high bound of the base type later on, and this should + -- always be compile time known. Again, it is not clear that this + -- can ever be false, but no point in bombing. + + if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then + Hbound := Expr_Value_R (Type_High_Bound (Btyp)); + Hi := Hbound; + + else + OK := False; + return; + end if; + + -- If we have a static subtype, then that may have a tighter bound so + -- use the upper bound of the subtype instead in this case. + + if Compile_Time_Known_Value (Bound) then + Hi := Expr_Value_R (Bound); + end if; + + -- We may be able to refine this value in certain situations. If any + -- refinement is possible, then Lor and Hir are set to possibly tighter + -- bounds, and OK1 is set to True. + + case Nkind (N) is + + -- For unary plus, result is limited by range of operand + + when N_Op_Plus => + Determine_Range_R + (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid); + + -- For unary minus, determine range of operand, and negate it + + when N_Op_Minus => + Determine_Range_R + (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); + + if OK1 then + Lor := -Hi_Right; + Hir := -Lo_Right; + end if; + + -- For binary addition, get range of each operand and do the + -- addition to get the result range. + + when N_Op_Add => + if OK_Operands then + Lor := Round_Machine (Lo_Left + Lo_Right); + Hir := Round_Machine (Hi_Left + Hi_Right); + end if; + + -- For binary subtraction, get range of each operand and do the worst + -- case subtraction to get the result range. + + when N_Op_Subtract => + if OK_Operands then + Lor := Round_Machine (Lo_Left - Hi_Right); + Hir := Round_Machine (Hi_Left - Lo_Right); + end if; + + -- For multiplication, get range of each operand and do the + -- four multiplications to get the result range. + + when N_Op_Multiply => + if OK_Operands then + declare + M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right); + M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right); + M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right); + M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right); + begin + Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4)); + Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4)); + end; + end if; + + -- For division, consider separately the cases where the right + -- operand is positive or negative. Otherwise, the right operand + -- can be arbitrarily close to zero, so the result is likely to + -- be unbounded in one direction, do not attempt to compute it. + + when N_Op_Divide => + if OK_Operands then + + -- Right operand is positive + + if Lo_Right > Ureal_0 then + + -- If the low bound of the left operand is negative, obtain + -- the overall low bound by dividing it by the smallest + -- value of the right operand, and otherwise by the largest + -- value of the right operand. + + if Lo_Left < Ureal_0 then + Lor := Round_Machine (Lo_Left / Lo_Right); + else + Lor := Round_Machine (Lo_Left / Hi_Right); + end if; + + -- If the high bound of the left operand is negative, obtain + -- the overall high bound by dividing it by the largest + -- value of the right operand, and otherwise by the + -- smallest value of the right operand. + + if Hi_Left < Ureal_0 then + Hir := Round_Machine (Hi_Left / Hi_Right); + else + Hir := Round_Machine (Hi_Left / Lo_Right); + end if; + + -- Right operand is negative + + elsif Hi_Right < Ureal_0 then + + -- If the low bound of the left operand is negative, obtain + -- the overall low bound by dividing it by the largest + -- value of the right operand, and otherwise by the smallest + -- value of the right operand. + + if Lo_Left < Ureal_0 then + Lor := Round_Machine (Lo_Left / Hi_Right); + else + Lor := Round_Machine (Lo_Left / Lo_Right); + end if; + + -- If the high bound of the left operand is negative, obtain + -- the overall high bound by dividing it by the smallest + -- value of the right operand, and otherwise by the + -- largest value of the right operand. + + if Hi_Left < Ureal_0 then + Hir := Round_Machine (Hi_Left / Lo_Right); + else + Hir := Round_Machine (Hi_Left / Hi_Right); + end if; + + else + OK1 := False; + end if; + end if; + + -- For type conversion from one floating-point type to another, we + -- can refine the range using the converted value. + + when N_Type_Conversion => + Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid); + + -- Nothing special to do for all other expression kinds + + when others => + OK1 := False; + Lor := No_Ureal; + Hir := No_Ureal; + end case; + + -- At this stage, if OK1 is true, then we know that the actual result of + -- the computed expression is in the range Lor .. Hir. We can use this + -- to restrict the possible range of results. + + if OK1 then + + -- If the refined value of the low bound is greater than the type + -- low bound, then reset it to the more restrictive value. + + if Lor > Lo then + Lo := Lor; + end if; + + -- Similarly, if the refined value of the high bound is less than the + -- value so far, then reset it to the more restrictive value. + + if Hir < Hi then + Hi := Hir; + end if; + end if; + + -- Set cache entry for future call and we are all done + + Determine_Range_Cache_N (Cindex) := N; + Determine_Range_Cache_V (Cindex) := Assume_Valid; + Determine_Range_Cache_Lo_R (Cindex) := Lo; + Determine_Range_Cache_Hi_R (Cindex) := Hi; + return; + + -- If any exception occurs, it means that we have some bug in the compiler, + -- possibly triggered by a previous error, or by some unforeseen peculiar + -- occurrence. However, this is only an optimization attempt, so there is + -- really no point in crashing the compiler. Instead we just decide, too + -- bad, we can't figure out a range in this case after all. + + exception + when others => + + -- Debug flag K disables this behavior (useful for debugging) + + if Debug_Flag_K then + raise; + else + OK := False; + Lo := No_Ureal; + Hi := No_Ureal; + return; + end if; + end Determine_Range_R; + ------------------------------------ -- Discriminant_Checks_Suppressed -- ------------------------------------ @@ -4673,7 +5145,7 @@ package body Checks is --------------------------- procedure Enable_Overflow_Check (N : Node_Id) is - Typ : constant Entity_Id := Base_Type (Etype (N)); + Typ : constant Entity_Id := Base_Type (Etype (N)); Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; Chk : Nat; OK : Boolean; @@ -4682,6 +5154,8 @@ package body Checks is Lo : Uint; Hi : Uint; + Do_Ovflow_Check : Boolean; + begin if Debug_Flag_CC then w ("Enable_Overflow_Check for node ", Int (N)); @@ -4759,15 +5233,52 @@ package body Checks is -- c) The alternative is a lot of special casing in this routine -- which would partially duplicate Determine_Range processing. - if OK - and then Lo > Expr_Value (Type_Low_Bound (Typ)) - and then Hi < Expr_Value (Type_High_Bound (Typ)) - then - if Debug_Flag_CC then - w ("No overflow check required"); + if OK then + Do_Ovflow_Check := True; + + -- Note that the following checks are quite deliberately > and < + -- rather than >= and <= as explained above. + + if Lo > Expr_Value (Type_Low_Bound (Typ)) + and then + Hi < Expr_Value (Type_High_Bound (Typ)) + then + Do_Ovflow_Check := False; + + -- Despite the comments above, it is worth dealing specially with + -- division specially. The only case where integer division can + -- overflow is (largest negative number) / (-1). So we will do + -- an extra range analysis to see if this is possible. + + elsif Nkind (N) = N_Op_Divide then + Determine_Range + (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); + + if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then + Do_Ovflow_Check := False; + + else + Determine_Range + (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); + + if OK and then (Lo > Uint_Minus_1 + or else + Hi < Uint_Minus_1) + then + Do_Ovflow_Check := False; + end if; + end if; end if; - return; + -- If no overflow check required, we are done + + if not Do_Ovflow_Check then + if Debug_Flag_CC then + w ("No overflow check required"); + end if; + + return; + end if; end if; end if; @@ -5627,7 +6138,7 @@ package body Checks is -- For an untagged derived type, use the discriminants of the parent -- which have been renamed in the derivation, possibly by a one-to-many - -- discriminant constraint. For non-tagged type, initially get the Etype + -- discriminant constraint. For untagged type, initially get the Etype -- of the prefix else @@ -5910,11 +6421,63 @@ package body Checks is Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); + procedure Convert_And_Check_Range; + -- Convert the conversion operand to the target base type and save in + -- a temporary. Then check the converted value against the range of the + -- target subtype. + + ----------------------------- + -- Convert_And_Check_Range -- + ----------------------------- + + procedure Convert_And_Check_Range is + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + + begin + -- We make a temporary to hold the value of the converted value + -- (converted to the base type), and then do the test against this + -- temporary. The conversion itself is replaced by an occurrence of + -- Tnn and followed by the explicit range check. Note that checks + -- are suppressed for this code, since we don't want a recursive + -- range check popping up. + + -- Tnn : constant Target_Base_Type := Target_Base_Type (N); + -- [constraint_error when Tnn not in Target_Type] + + Insert_Actions (N, New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), + Constant_Present => True, + Expression => + Make_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), + Expression => Duplicate_Subexpr (N))), + + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => New_Occurrence_Of (Tnn, Loc), + Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), + Reason => Reason)), + Suppress => All_Checks); + + Rewrite (N, New_Occurrence_Of (Tnn, Loc)); + + -- Set the type of N, because the declaration for Tnn might not + -- be analyzed yet, as is the case if N appears within a record + -- declaration, as a discriminant constraint or expression. + + Set_Etype (N, Target_Base_Type); + end Convert_And_Check_Range; + + -- Start of processing for Generate_Range_Check + begin -- First special case, if the source type is already within the range -- of the target type, then no check is needed (probably we should have -- stopped Do_Range_Check from being set in the first place, but better - -- late than never in preventing junk code. + -- late than never in preventing junk code and junk flag settings. if In_Subrange_Of (Source_Type, Target_Type) @@ -5927,19 +6490,31 @@ package body Checks is or else (Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Enumeration_Literal)) + then + Set_Do_Range_Check (N, False); + return; + end if; - -- Also do not apply this for floating-point if Check_Float_Overflow + -- Here a check is needed. If the expander is not active, or if we are + -- in GNATProve mode, then simply set the Do_Range_Check flag and we + -- are done. In both these cases, we just want to see the range check + -- flag set, we do not want to generate the explicit range check code. - and then not - (Is_Floating_Point_Type (Source_Type) and Check_Float_Overflow) - then + if GNATprove_Mode or else not Expander_Active then + Set_Do_Range_Check (N, True); return; end if; - -- We need a check, so force evaluation of the node, so that it does - -- not get evaluated 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. + -- Here we will generate an explicit range check, so we don't want to + -- set the Do_Range check flag, since the range check is taken care of + -- by the code we will generate. + + Set_Do_Range_Check (N, False); + + -- Force evaluation of the node, so that it does not get evaluated 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. if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then Force_Evaluation (N); @@ -5956,13 +6531,18 @@ package body Checks is -- cases are like this. Notably conversions can involve two types. if Source_Base_Type = Target_Base_Type then + + -- Insert the explicit range check. Note that we suppress checks for + -- this code, since we don't want a recursive range check popping up. + Insert_Action (N, Make_Raise_Constraint_Error (Loc, Condition => Make_Not_In (Loc, Left_Opnd => Duplicate_Subexpr (N), Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), - Reason => Reason)); + Reason => Reason), + Suppress => All_Checks); -- Next test for the case where the target type is within the bounds -- of the base type of the source type, since in this case we can @@ -5982,28 +6562,48 @@ package body Checks is -- itself does not require a check. elsif In_Subrange_Of (Target_Type, Source_Base_Type) then - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Not_In (Loc, - Left_Opnd => Duplicate_Subexpr (N), - Right_Opnd => - Make_Range (Loc, - Low_Bound => - Unchecked_Convert_To (Source_Base_Type, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Target_Type, Loc), - Attribute_Name => Name_First)), - - High_Bound => - Unchecked_Convert_To (Source_Base_Type, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Target_Type, Loc), - Attribute_Name => Name_Last)))), - Reason => Reason)); + -- Insert the explicit range check. Note that we suppress checks for + -- this code, since we don't want a recursive range check popping up. + + if Is_Discrete_Type (Source_Base_Type) + and then + Is_Discrete_Type (Target_Base_Type) + then + Insert_Action (N, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Not_In (Loc, + Left_Opnd => Duplicate_Subexpr (N), + + Right_Opnd => + Make_Range (Loc, + Low_Bound => + Unchecked_Convert_To (Source_Base_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_First)), + + High_Bound => + Unchecked_Convert_To (Source_Base_Type, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Target_Type, Loc), + Attribute_Name => Name_Last)))), + Reason => Reason), + Suppress => All_Checks); + + -- For conversions involving at least one type that is not discrete, + -- first convert to target type and then generate the range check. + -- This avoids problems with values that are close to a bound of the + -- target type that would fail a range check when done in a larger + -- source type before converting but would pass if converted with + -- rounding and then checked (such as in float-to-float conversions). + + else + Convert_And_Check_Range; + end if; -- Note that at this stage we now that the Target_Base_Type is not in -- the range of the Source_Base_Type (since even the Target_Type itself @@ -6014,47 +6614,7 @@ package body Checks is -- and then test the target result against the bounds. elsif In_Subrange_Of (Source_Type, Target_Base_Type) then - - -- We make a temporary to hold the value of the converted value - -- (converted to the base type), and then we will do the test against - -- this temporary. - - -- Tnn : constant Target_Base_Type := Target_Base_Type (N); - -- [constraint_error when Tnn not in Target_Type] - - -- Then the conversion itself is replaced by an occurrence of Tnn - - declare - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); - - begin - Insert_Actions (N, New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, - Object_Definition => - New_Occurrence_Of (Target_Base_Type, Loc), - Constant_Present => True, - Expression => - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), - Expression => Duplicate_Subexpr (N))), - - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Not_In (Loc, - Left_Opnd => New_Occurrence_Of (Tnn, Loc), - Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), - - Reason => Reason))); - - Rewrite (N, New_Occurrence_Of (Tnn, Loc)); - - -- Set the type of N, because the declaration for Tnn might not - -- be analyzed yet, as is the case if N appears within a record - -- declaration, as a discriminant constraint or expression. - - Set_Etype (N, Target_Base_Type); - end; + Convert_And_Check_Range; -- At this stage, we know that we have two scalar types, which are -- directly convertible, and where neither scalar type has a base @@ -6518,7 +7078,8 @@ package body Checks is -- A rather specialized test. If PV is an analyzed expression which -- is an indexed component of a packed array that has not been -- properly expanded, turn off its Analyzed flag to make sure it - -- gets properly reexpanded. + -- gets properly reexpanded. If the prefix is an access value, + -- the dereference will be added later. -- The reason this arises is that Duplicate_Subexpr_No_Checks did -- an analyze with the old parent pointer. This may point e.g. to @@ -6526,6 +7087,7 @@ package body Checks is if Analyzed (PV) and then Nkind (PV) = N_Indexed_Component + and then Is_Array_Type (Etype (Prefix (PV))) and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV)))) then Set_Analyzed (PV, False); @@ -6876,7 +7438,7 @@ package body Checks is -------------------------- procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is - Stat : constant Boolean := Is_Static_Expression (R_Cno); + Stat : constant Boolean := Is_OK_Static_Expression (R_Cno); Typ : constant Entity_Id := Etype (R_Cno); begin @@ -7012,26 +7574,14 @@ package body Checks is function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM); - begin return Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => M, - Object_Definition => - New_Occurrence_Of (RTE (RE_Mark_Id), Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)))), - + Declarations => + New_List (Build_SS_Mark_Call (Loc, M)), Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_SS_Release), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (M, Loc)))))); + Statements => New_List (Build_SS_Release_Call (Loc, M)))); end Make_Bignum_Block; ---------------------------------- @@ -7148,7 +7698,7 @@ package body Checks is if Lo = No_Uint or else Hi = No_Uint then return False; - elsif Is_Static_Subtype (Etype (N)) then + elsif Is_OK_Static_Subtype (Etype (N)) then return Lo >= Expr_Value (Type_Low_Bound (Rtyp)) and then Hi <= Expr_Value (Type_High_Bound (Rtyp)); @@ -8011,14 +8561,9 @@ package body Checks is function Range_Checks_Suppressed (E : Entity_Id) return Boolean is begin if Present (E) then - - -- Note: for now we always suppress range checks on Vax float types, - -- since Gigi does not know how to generate these checks. - - if Vax_Float (E) then - return True; - elsif Kill_Range_Checks (E) then + if Kill_Range_Checks (E) then return True; + elsif Checks_May_Be_Suppressed (E) then return Is_Check_Suppressed (E, Range_Check); end if; @@ -8061,9 +8606,7 @@ package body Checks is declare Typ : constant Entity_Id := Etype (Expr); begin - if Vax_Float (Typ) then - return True; - elsif Checks_May_Be_Suppressed (Typ) + if Checks_May_Be_Suppressed (Typ) and then (Is_Check_Suppressed (Typ, Range_Check) or else Is_Check_Suppressed (Typ, Validity_Check)) diff --git a/main/gcc/ada/checks.ads b/main/gcc/ada/checks.ads index e1b538d9712..2dca67e1c4a 100644 --- a/main/gcc/ada/checks.ads +++ b/main/gcc/ada/checks.ads @@ -40,6 +40,7 @@ with Namet; use Namet; with Table; with Types; use Types; with Uintp; use Uintp; +with Urealp; use Urealp; package Checks is @@ -144,8 +145,19 @@ package Checks is -- Sets Do_Overflow_Check flag in node N, and handles possible local raise. -- Always call this routine rather than calling Set_Do_Overflow_Check to -- set an explicit value of True, to ensure handling the local raise case. - -- Note that this call has no effect for MOD, REM, and unary "+" for which - -- overflow is never possible in any case. + -- Note that for discrete types, this call has no effect for MOD, REM, and + -- unary "+" for which overflow is never possible in any case. + -- + -- Note: for the discrete-type case, it is legitimate to call this routine + -- on an unanalyzed node where the Etype field is not set. However, for the + -- floating-point case, Etype must be set (to a floating-point type). + -- + -- For floating-point, we set the flag if we have automatic overflow checks + -- on the target, or if Check_Float_Overflow mode is set. For the floating- + -- point case, we ignore all the unary operators ("+", "-", and abs) since + -- none of these can result in overflow. If there are no overflow checks on + -- the target, and Check_Float_Overflow mode is not set, then the call has + -- no effect, since in such cases we want to generate NaN's and infinities. procedure Activate_Range_Check (N : Node_Id); pragma Inline (Activate_Range_Check); @@ -245,8 +257,7 @@ package Checks is 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. The check is applied only - -- if the type of N does not match Typ. + -- for Typ, if Typ has a predicate function. procedure Apply_Type_Conversion_Checks (N : Node_Id); -- N is an N_Type_Conversion node. A type conversion actually involves @@ -303,6 +314,20 @@ package Checks is -- then this assumption is valid, if False, then processing is done using -- base types to allow invalid values. + procedure Determine_Range_R + (N : Node_Id; + OK : out Boolean; + Lo : out Ureal; + Hi : out Ureal; + Assume_Valid : Boolean := False); + -- Similar to Determine_Range, but for a node N of floating-point type. OK + -- is True on return only for IEEE floating-point types and only if we do + -- not have to worry about extended precision (i.e. on the x86, we must be + -- using -msse2 -mfpmath=sse). At the current time, this is used only in + -- GNATprove, though we could consider using it more generally in future. + -- For that to happen, the possibility of arguments of infinite or NaN + -- value should be taken into account, which is not the case currently. + procedure Install_Null_Excluding_Check (N : Node_Id); -- Determines whether an access node requires a runtime access check and -- if so inserts the appropriate run-time check. @@ -660,12 +685,19 @@ package Checks is -- The Reason parameter is the exception code to be used for the exception -- if raised. -- - -- Note on the relation of this routine to the Do_Range_Check flag. Mostly - -- for historical reasons, we often set the Do_Range_Check flag and then - -- later we call Generate_Range_Check if this flag is set. Most probably we - -- could eliminate this intermediate setting of the flag (historically the - -- back end dealt with range checks, using this flag to indicate if a check - -- was required, then we moved checks into the front end). + -- Note: if the expander is not active, or if we are in GNATprove mode, + -- then we do not generate explicit range code. Instead we just turn the + -- Do_Range_Check flag on, since in these cases that's what we want to see + -- in the tree (GNATprove in particular depends on this flag being set). If + -- we generate the actual range check, then we make sure the flag is off, + -- since the code we generate takes complete care of the check. + -- + -- Historical note: We used to just pass on the Do_Range_Check flag to the + -- back end to generate the check, but now in code-generation mode we never + -- have this flag set, since the front end takes care of the check. The + -- normal processing flow now is that the analyzer typically turns on the + -- Do_Range_Check flag, and if it is set, this routine is called, which + -- turns the flag off in code-generation mode. procedure Generate_Index_Checks (N : Node_Id); -- This procedure is called to generate index checks on the subscripts for diff --git a/main/gcc/ada/clean.adb b/main/gcc/ada/clean.adb index 0a7108d74a3..999c735fe12 100644 --- a/main/gcc/ada/clean.adb +++ b/main/gcc/ada/clean.adb @@ -55,8 +55,8 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; package body Clean is Initialized : Boolean := False; - -- Set to True by the first call to Initialize. - -- To avoid reinitialization of some packages. + -- Set to True by the first call to Initialize to avoid reinitialization + -- of some packages. -- Suffixes of various files @@ -64,15 +64,12 @@ package body Clean is ALI_Suffix : constant String := ".ali"; Tree_Suffix : constant String := ".adt"; Object_Suffix : constant String := Get_Target_Object_Suffix.all; - Debug_Suffix : String := ".dg"; - -- Changed to "_dg" for VMS in the body of the package + Debug_Suffix : constant String := ".dg"; + Repinfo_Suffix : constant String := ".rep"; + -- Suffix of representation info files - Repinfo_Suffix : String := ".rep"; - -- Changed to "_rep" for VMS in the body of the package - - B_Start : String_Ptr := new String'("b~"); - -- Prefix of binder generated file, and number of actual characters used. - -- Changed to "b__" for VMS in the body of the package. + B_Start : constant String := "b~"; + -- Prefix of binder generated file, and number of actual characters used Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); @@ -666,51 +663,58 @@ package body Clean is Canonical_Case_File_Name (Archive_Name); Canonical_Case_File_Name (DLL_Name); - Change_Dir (Lib_Directory); - Open (Direc, "."); + if Is_Directory (Lib_Directory) then + Change_Dir (Lib_Directory); + Open (Direc, "."); - -- For each regular file in the directory, if switch -n has not - -- been specified, make it writable and delete the file if it is - -- the library file. + -- For each regular file in the directory, if switch -n has not + -- not been specified, make it writable and delete the file if + -- it is the library file. - loop - Read (Direc, Name, Last); - exit when Last = 0; - - declare - Filename : constant String := Name (1 .. Last); + loop + Read (Direc, Name, Last); + exit when Last = 0; - begin - if Is_Regular_File (Filename) - or else Is_Symbolic_Link (Filename) - then - Canonical_Case_File_Name (Name (1 .. Last)); - Delete_File := False; + declare + Filename : constant String := Name (1 .. Last); - if (Project.Library_Kind = Static - and then Name (1 .. Last) = Archive_Name) - or else - ((Project.Library_Kind = Dynamic - or else - Project.Library_Kind = Relocatable) - and then - (Name (1 .. Last) = DLL_Name - or else - Name (1 .. Last) = Minor.all - or else - Name (1 .. Last) = Major.all)) + begin + if Is_Regular_File (Filename) + or else Is_Symbolic_Link (Filename) then - if not Do_Nothing then - Set_Writable (Filename); - end if; + Canonical_Case_File_Name (Name (1 .. Last)); + Delete_File := False; + + if (Project.Library_Kind = Static + and then Name (1 .. Last) = Archive_Name) + or else + ((Project.Library_Kind = Dynamic + or else + Project.Library_Kind = Relocatable) + and then + (Name (1 .. Last) = DLL_Name + or else + Name (1 .. Last) = Minor.all + or else + Name (1 .. Last) = Major.all)) + then + if not Do_Nothing then + Set_Writable (Filename); + end if; - Delete (Lib_Directory, Filename); + Delete (Lib_Directory, Filename); + end if; end if; - end if; - end; - end loop; + end; + end loop; - Close (Direc); + Close (Direc); + end if; + + if not Is_Directory (Lib_ALI_Directory) then + -- Nothing more to do, return now + return; + end if; Change_Dir (Lib_ALI_Directory); Open (Direc, "."); @@ -733,11 +737,12 @@ package body Clean is if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then declare Unit : Unit_Index; + begin -- Compare with ALI file names of the project - Unit := Units_Htable.Get_First - (Project_Tree.Units_HT); + Unit := + Units_Htable.Get_First (Project_Tree.Units_HT); while Unit /= No_Unit_Index loop if Unit.File_Names (Impl) /= null and then Unit.File_Names (Impl).Project /= @@ -749,9 +754,10 @@ package body Clean is then Get_Name_String (Unit.File_Names (Impl).File); - Name_Len := Name_Len - - File_Extension - (Name (1 .. Name_Len))'Length; + Name_Len := + Name_Len - + File_Extension + (Name (1 .. Name_Len))'Length; if Name_Buffer (1 .. Name_Len) = Name (1 .. Last - 4) then @@ -765,8 +771,7 @@ package body Clean is (Unit.File_Names (Spec).Project) = Project then - Get_Name_String - (Unit.File_Names (Spec).File); + Get_Name_String (Unit.File_Names (Spec).File); Name_Len := Name_Len - File_Extension @@ -860,7 +865,10 @@ package body Clean is Processed_Projects.Increment_Last; Processed_Projects.Table (Processed_Projects.Last) := Project; - if Project.Object_Directory /= No_Path_Information then + if Project.Object_Directory /= No_Path_Information + and then Is_Directory + (Get_Name_String (Project.Object_Directory.Display_Name)) + then declare Obj_Dir : constant String := Get_Name_String (Project.Object_Directory.Display_Name); @@ -894,8 +902,9 @@ package body Clean is (Unit.File_Names (Impl).Project, Project)) or else (Unit.File_Names (Spec) /= null - and then In_Extension_Chain - (Unit.File_Names (Spec).Project, Project)) + and then + In_Extension_Chain + (Unit.File_Names (Spec).Project, Project)) then if Unit.File_Names (Impl) /= null then File_Name1 := Unit.File_Names (Impl).File; @@ -932,17 +941,17 @@ package body Clean is declare Asm : constant String := - Assembly_File_Name (Lib_File); + Assembly_File_Name (Lib_File); ALI : constant String := - ALI_File_Name (Lib_File); + ALI_File_Name (Lib_File); Obj : constant String := - Object_File_Name (Lib_File); + Object_File_Name (Lib_File); Adt : constant String := - Tree_File_Name (Lib_File); + Tree_File_Name (Lib_File); Deb : constant String := - Debug_File_Name (File_Name1); + Debug_File_Name (File_Name1); Rep : constant String := - Repinfo_File_Name (File_Name1); + Repinfo_File_Name (File_Name1); Del : Boolean := True; begin @@ -1188,7 +1197,11 @@ package body Clean is end; end if; - if Project.Object_Directory /= No_Path_Information then + if Project.Object_Directory /= No_Path_Information + and then + Is_Directory + (Get_Name_String (Project.Object_Directory.Display_Name)) + then Delete_Binder_Generated_Files (Get_Name_String (Project.Object_Directory.Display_Name), Strip_Suffix (Main_Source_File)); @@ -1250,27 +1263,7 @@ package body Clean is or else Is_Writable_File (Full_Name (1 .. Last)) or else Is_Symbolic_Link (Full_Name (1 .. Last)) then - -- On VMS, we have to delete all versions of the file - - if OpenVMS_On_Target then - declare - Host_Full_Name : constant String_Access := - To_Host_File_Spec (Full_Name (1 .. Last)); - begin - if Host_Full_Name = null - or else Host_Full_Name'Length = 0 - then - Success := False; - else - Delete_File (Host_Full_Name.all & ";*", Success); - end if; - end; - - -- Otherwise just delete the specified file - - else - Delete_File (Full_Name (1 .. Last), Success); - end if; + Delete_File (Full_Name (1 .. Last), Success); -- Here if no deletion required @@ -1311,7 +1304,7 @@ package body Clean is -- Build the file name (before the extension) - File_Name (1 .. B_Start'Length) := B_Start.all; + File_Name (1 .. B_Start'Length) := B_Start; File_Name (B_Start'Length + 1 .. Last) := Source_Name; -- Spec @@ -1574,16 +1567,7 @@ package body Clean is Prj.Tree.Initialize (Project_Node_Tree); Prj.Initialize (Project_Tree); - - -- Check if the platform is VMS and, if it is, change some variables - Targparm.Get_Target_Parameters; - - if OpenVMS_On_Target then - Debug_Suffix (Debug_Suffix'First) := '_'; - Repinfo_Suffix (Repinfo_Suffix'First) := '_'; - B_Start := new String'("b__"); - end if; end if; -- Reset global variables @@ -1798,8 +1782,7 @@ package body Clean is declare Prj : constant String := Arg (3 .. Arg'Last); begin - if Prj'Length > 1 and then - Prj (Prj'First) = '=' + if Prj'Length > 1 and then Prj (Prj'First) = '=' then Project_File_Name := new String' diff --git a/main/gcc/ada/cstand.adb b/main/gcc/ada/cstand.adb index 4099a7d0457..2fe357666da 100644 --- a/main/gcc/ada/cstand.adb +++ b/main/gcc/ada/cstand.adb @@ -151,6 +151,10 @@ package body CStand is (New_Node_Kind : Node_Kind := N_Defining_Identifier) return Entity_Id; -- Builds a new entity for Standard + function New_Standard_Entity (S : String) return Entity_Id; + -- Builds a new entity for Standard with Nkind = N_Defining_Identifier, + -- and Chars of this defining identifier set to the given string S. + procedure Print_Standard; -- Print representation of package Standard if switch set @@ -450,6 +454,9 @@ package body CStand is -- Creates entities for all predefined floating point types, and -- adds these to the Predefined_Float_Types list in package Standard. + procedure Make_Dummy_Index (E : Entity_Id); + -- Called to provide a dummy index field value for Any_Array/Any_String + procedure Pack_String_Type (String_Type : Entity_Id); -- Generate proper tree for pragma Pack that applies to given type, and -- mark type as having the pragma. @@ -460,10 +467,9 @@ package body CStand is procedure Build_Exception (S : Standard_Entity_Type) is begin - Set_Ekind (Standard_Entity (S), E_Exception); - Set_Etype (Standard_Entity (S), Standard_Exception_Type); - Set_Exception_Code (Standard_Entity (S), Uint_0); - Set_Is_Public (Standard_Entity (S), True); + Set_Ekind (Standard_Entity (S), E_Exception); + Set_Etype (Standard_Entity (S), Standard_Exception_Type); + Set_Is_Public (Standard_Entity (S), True); Decl := Make_Exception_Declaration (Stloc, @@ -554,6 +560,27 @@ package body CStand is end Create_Float_Types; ---------------------- + -- Make_Dummy_Index -- + ---------------------- + + procedure Make_Dummy_Index (E : Entity_Id) is + Index : Node_Id; + Dummy : List_Id; + + begin + Index := + Make_Range (Sloc (E), + Low_Bound => Make_Integer (Uint_0), + High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size)); + Set_Etype (Index, Standard_Integer); + Set_First_Index (E, Index); + + -- Make sure Index is a list as required, so Next_Index is Empty + + Dummy := New_List (Index); + end Make_Dummy_Index; + + ---------------------- -- Pack_String_Type -- ---------------------- @@ -712,17 +739,8 @@ package body CStand is Build_Signed_Integer_Type (Standard_Integer, Standard_Integer_Size); - declare - LIS : Nat; - begin - if Debug_Flag_M then - LIS := 64; - else - LIS := Standard_Long_Integer_Size; - end if; - - Build_Signed_Integer_Type (Standard_Long_Integer, LIS); - end; + Build_Signed_Integer_Type + (Standard_Long_Integer, Standard_Long_Integer_Size); Build_Signed_Integer_Type (Standard_Long_Long_Integer, Standard_Long_Long_Integer_Size); @@ -907,7 +925,7 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_String), Tdef_Node); - Set_Ekind (Standard_String, E_String_Type); + Set_Ekind (Standard_String, E_Array_Type); Set_Etype (Standard_String, Standard_String); Set_Component_Type (Standard_String, Standard_Character); Set_Component_Size (Standard_String, Uint_8); @@ -926,8 +944,8 @@ package body CStand is -- Set index type of String - E_Id := First - (Subtype_Marks (Type_Definition (Parent (Standard_String)))); + E_Id := + First (Subtype_Marks (Type_Definition (Parent (Standard_String)))); Set_First_Index (Standard_String, E_Id); Set_Entity (E_Id, Standard_Positive); Set_Etype (E_Id, Standard_Positive); @@ -951,7 +969,7 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_Wide_String), Tdef_Node); - Set_Ekind (Standard_Wide_String, E_String_Type); + Set_Ekind (Standard_Wide_String, E_Array_Type); Set_Etype (Standard_Wide_String, Standard_Wide_String); Set_Component_Type (Standard_Wide_String, Standard_Wide_Character); Set_Component_Size (Standard_Wide_String, Uint_16); @@ -960,8 +978,9 @@ package body CStand is -- Set index type of Wide_String - E_Id := First - (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String)))); + E_Id := + First + (Subtype_Marks (Type_Definition (Parent (Standard_Wide_String)))); Set_First_Index (Standard_Wide_String, E_Id); Set_Entity (E_Id, Standard_Positive); Set_Etype (E_Id, Standard_Positive); @@ -985,7 +1004,7 @@ package body CStand is Append (Identifier_For (S_Positive), Subtype_Marks (Tdef_Node)); Set_Type_Definition (Parent (Standard_Wide_Wide_String), Tdef_Node); - Set_Ekind (Standard_Wide_Wide_String, E_String_Type); + Set_Ekind (Standard_Wide_Wide_String, E_Array_Type); Set_Etype (Standard_Wide_Wide_String, Standard_Wide_Wide_String); Set_Component_Type (Standard_Wide_Wide_String, @@ -997,8 +1016,10 @@ package body CStand is -- Set index type of Wide_Wide_String - E_Id := First - (Subtype_Marks (Type_Definition (Parent (Standard_Wide_Wide_String)))); + E_Id := + First + (Subtype_Marks + (Type_Definition (Parent (Standard_Wide_Wide_String)))); Set_First_Index (Standard_Wide_Wide_String, E_Id); Set_Entity (E_Id, Standard_Positive); Set_Etype (E_Id, Standard_Positive); @@ -1177,30 +1198,27 @@ package body CStand is -- filled out to minimize problems with cascaded errors (for example, -- Any_Integer is given reasonable and consistent type and size values) - Any_Type := New_Standard_Entity; + Any_Type := New_Standard_Entity ("any type"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Any_Type); Set_Scope (Any_Type, Standard_Standard); Build_Signed_Integer_Type (Any_Type, Standard_Integer_Size); - Make_Name (Any_Type, "any type"); - Any_Id := New_Standard_Entity; + Any_Id := New_Standard_Entity ("any id"); Set_Ekind (Any_Id, E_Variable); Set_Scope (Any_Id, Standard_Standard); Set_Etype (Any_Id, Any_Type); Init_Esize (Any_Id); Init_Alignment (Any_Id); - Make_Name (Any_Id, "any id"); - Any_Access := New_Standard_Entity; + Any_Access := New_Standard_Entity ("an access type"); Set_Ekind (Any_Access, E_Access_Type); Set_Scope (Any_Access, Standard_Standard); Set_Etype (Any_Access, Any_Access); Init_Size (Any_Access, System_Address_Size); Set_Elem_Alignment (Any_Access); - Make_Name (Any_Access, "an access type"); - Any_Character := New_Standard_Entity; + Any_Character := New_Standard_Entity ("a character type"); Set_Ekind (Any_Character, E_Enumeration_Type); Set_Scope (Any_Character, Standard_Standard); Set_Etype (Any_Character, Any_Character); @@ -1210,17 +1228,16 @@ package body CStand is Init_RM_Size (Any_Character, 8); Set_Elem_Alignment (Any_Character); Set_Scalar_Range (Any_Character, Scalar_Range (Standard_Character)); - Make_Name (Any_Character, "a character type"); - Any_Array := New_Standard_Entity; - Set_Ekind (Any_Array, E_String_Type); + Any_Array := New_Standard_Entity ("an array type"); + Set_Ekind (Any_Array, E_Array_Type); Set_Scope (Any_Array, Standard_Standard); Set_Etype (Any_Array, Any_Array); Set_Component_Type (Any_Array, Any_Character); Init_Size_Align (Any_Array); - Make_Name (Any_Array, "an array type"); + Make_Dummy_Index (Any_Array); - Any_Boolean := New_Standard_Entity; + Any_Boolean := New_Standard_Entity ("a boolean type"); Set_Ekind (Any_Boolean, E_Enumeration_Type); Set_Scope (Any_Boolean, Standard_Standard); Set_Etype (Any_Boolean, Standard_Boolean); @@ -1229,34 +1246,30 @@ package body CStand is Set_Elem_Alignment (Any_Boolean); Set_Is_Unsigned_Type (Any_Boolean); Set_Scalar_Range (Any_Boolean, Scalar_Range (Standard_Boolean)); - Make_Name (Any_Boolean, "a boolean type"); - Any_Composite := New_Standard_Entity; + Any_Composite := New_Standard_Entity ("a composite type"); Set_Ekind (Any_Composite, E_Array_Type); Set_Scope (Any_Composite, Standard_Standard); Set_Etype (Any_Composite, Any_Composite); Set_Component_Size (Any_Composite, Uint_0); Set_Component_Type (Any_Composite, Standard_Integer); Init_Size_Align (Any_Composite); - Make_Name (Any_Composite, "a composite type"); - Any_Discrete := New_Standard_Entity; + Any_Discrete := New_Standard_Entity ("a discrete type"); Set_Ekind (Any_Discrete, E_Signed_Integer_Type); Set_Scope (Any_Discrete, Standard_Standard); Set_Etype (Any_Discrete, Any_Discrete); Init_Size (Any_Discrete, Standard_Integer_Size); Set_Elem_Alignment (Any_Discrete); - Make_Name (Any_Discrete, "a discrete type"); - Any_Fixed := New_Standard_Entity; + Any_Fixed := New_Standard_Entity ("a fixed-point type"); Set_Ekind (Any_Fixed, E_Ordinary_Fixed_Point_Type); Set_Scope (Any_Fixed, Standard_Standard); Set_Etype (Any_Fixed, Any_Fixed); Init_Size (Any_Fixed, Standard_Integer_Size); Set_Elem_Alignment (Any_Fixed); - Make_Name (Any_Fixed, "a fixed-point type"); - Any_Integer := New_Standard_Entity; + Any_Integer := New_Standard_Entity ("an integer type"); Set_Ekind (Any_Integer, E_Signed_Integer_Type); Set_Scope (Any_Integer, Standard_Standard); Set_Etype (Any_Integer, Standard_Long_Long_Integer); @@ -1268,94 +1281,72 @@ package body CStand is Typ => Base_Type (Standard_Integer), Lb => Uint_0, Hb => Intval (High_Bound (Scalar_Range (Standard_Integer)))); - Make_Name (Any_Integer, "an integer type"); - Any_Modular := New_Standard_Entity; + Any_Modular := New_Standard_Entity ("a modular type"); Set_Ekind (Any_Modular, E_Modular_Integer_Type); Set_Scope (Any_Modular, Standard_Standard); Set_Etype (Any_Modular, Standard_Long_Long_Integer); Init_Size (Any_Modular, Standard_Long_Long_Integer_Size); Set_Elem_Alignment (Any_Modular); Set_Is_Unsigned_Type (Any_Modular); - Make_Name (Any_Modular, "a modular type"); - Any_Numeric := New_Standard_Entity; + Any_Numeric := New_Standard_Entity ("a numeric type"); Set_Ekind (Any_Numeric, E_Signed_Integer_Type); Set_Scope (Any_Numeric, Standard_Standard); Set_Etype (Any_Numeric, Standard_Long_Long_Integer); Init_Size (Any_Numeric, Standard_Long_Long_Integer_Size); Set_Elem_Alignment (Any_Numeric); - Make_Name (Any_Numeric, "a numeric type"); - Any_Real := New_Standard_Entity; + Any_Real := New_Standard_Entity ("a real type"); Set_Ekind (Any_Real, E_Floating_Point_Type); Set_Scope (Any_Real, Standard_Standard); Set_Etype (Any_Real, Standard_Long_Long_Float); Init_Size (Any_Real, UI_To_Int (Esize (Standard_Long_Long_Float))); Set_Elem_Alignment (Any_Real); - Make_Name (Any_Real, "a real type"); - Any_Scalar := New_Standard_Entity; + Any_Scalar := New_Standard_Entity ("a scalar type"); Set_Ekind (Any_Scalar, E_Signed_Integer_Type); Set_Scope (Any_Scalar, Standard_Standard); Set_Etype (Any_Scalar, Any_Scalar); Init_Size (Any_Scalar, Standard_Integer_Size); Set_Elem_Alignment (Any_Scalar); - Make_Name (Any_Scalar, "a scalar type"); - Any_String := New_Standard_Entity; - Set_Ekind (Any_String, E_String_Type); + Any_String := New_Standard_Entity ("a string type"); + Set_Ekind (Any_String, E_Array_Type); Set_Scope (Any_String, Standard_Standard); Set_Etype (Any_String, Any_String); Set_Component_Type (Any_String, Any_Character); Init_Size_Align (Any_String); - Make_Name (Any_String, "a string type"); - - declare - Index : Node_Id; + Make_Dummy_Index (Any_String); - begin - Index := - Make_Range (Stloc, - Low_Bound => Make_Integer (Uint_0), - High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size)); - Set_Etype (Index, Standard_Integer); - Set_First_Index (Any_String, Index); - end; - - Raise_Type := New_Standard_Entity; + Raise_Type := New_Standard_Entity ("raise type"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Raise_Type); Set_Scope (Raise_Type, Standard_Standard); Build_Signed_Integer_Type (Raise_Type, Standard_Integer_Size); - Make_Name (Raise_Type, "any type"); - Standard_Integer_8 := New_Standard_Entity; + Standard_Integer_8 := New_Standard_Entity ("integer_8"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Standard_Integer_8); - Make_Name (Standard_Integer_8, "integer_8"); Set_Scope (Standard_Integer_8, Standard_Standard); Build_Signed_Integer_Type (Standard_Integer_8, 8); - Standard_Integer_16 := New_Standard_Entity; + Standard_Integer_16 := New_Standard_Entity ("integer_16"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Standard_Integer_16); - Make_Name (Standard_Integer_16, "integer_16"); Set_Scope (Standard_Integer_16, Standard_Standard); Build_Signed_Integer_Type (Standard_Integer_16, 16); - Standard_Integer_32 := New_Standard_Entity; + Standard_Integer_32 := New_Standard_Entity ("integer_32"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Standard_Integer_32); - Make_Name (Standard_Integer_32, "integer_32"); Set_Scope (Standard_Integer_32, Standard_Standard); Build_Signed_Integer_Type (Standard_Integer_32, 32); - Standard_Integer_64 := New_Standard_Entity; + Standard_Integer_64 := New_Standard_Entity ("integer_64"); Decl := New_Node (N_Full_Type_Declaration, Stloc); Set_Defining_Identifier (Decl, Standard_Integer_64); - Make_Name (Standard_Integer_64, "integer_64"); Set_Scope (Standard_Integer_64, Standard_Standard); Build_Signed_Integer_Type (Standard_Integer_64, 64); @@ -1598,7 +1589,6 @@ package body CStand is E_Id := Standard_Entity (S_Numeric_Error); Set_Ekind (E_Id, E_Exception); - Set_Exception_Code (E_Id, Uint_0); Set_Etype (E_Id, Standard_Exception_Type); Set_Is_Public (E_Id); Set_Renamed_Entity (E_Id, Standard_Entity (S_Constraint_Error)); @@ -1615,12 +1605,11 @@ package body CStand is -- Abort_Signal is an entity that does not get made visible Abort_Signal := New_Standard_Entity; - Set_Chars (Abort_Signal, Name_uAbort_Signal); - Set_Ekind (Abort_Signal, E_Exception); - Set_Exception_Code (Abort_Signal, Uint_0); - Set_Etype (Abort_Signal, Standard_Exception_Type); - Set_Scope (Abort_Signal, Standard_Standard); - Set_Is_Public (Abort_Signal, True); + Set_Chars (Abort_Signal, Name_uAbort_Signal); + Set_Ekind (Abort_Signal, E_Exception); + Set_Etype (Abort_Signal, Standard_Exception_Type); + Set_Scope (Abort_Signal, Standard_Standard); + Set_Is_Public (Abort_Signal, True); Decl := Make_Exception_Declaration (Stloc, Defining_Identifier => Abort_Signal); @@ -1862,6 +1851,13 @@ package body CStand is return E; end New_Standard_Entity; + function New_Standard_Entity (S : String) return Entity_Id is + Ent : constant Entity_Id := New_Standard_Entity; + begin + Make_Name (Ent, S); + return Ent; + end New_Standard_Entity; + -------------------- -- Print_Standard -- -------------------- @@ -2126,11 +2122,6 @@ package body CStand is Exponent : constant Uint := Emax - Mantissa; begin - -- Note: for the call from Cstand to initially create the types in - -- Standard, Float_Rep will never be VAX_Native. Circuitry in Sem_Vfpt - -- will adjust these types appropriately VAX_Native if a pragma - -- Float_Representation (VAX_Float) is used. - H := Make_Float_Literal (Stloc, Radix, Significand, Exponent); L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent); diff --git a/main/gcc/ada/cstreams.c b/main/gcc/ada/cstreams.c index 25a867a768f..f7652e32aa9 100644 --- a/main/gcc/ada/cstreams.c +++ b/main/gcc/ada/cstreams.c @@ -6,7 +6,7 @@ * * * Auxiliary C functions for Interfaces.C.Streams * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, Free Software Foundation, Inc. * * * * GNAT is 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,21 @@ /* Routines required for implementing routines in Interfaces.C.Streams. */ +#ifndef _LARGEFILE_SOURCE +#define _LARGEFILE_SOURCE +#endif +#define _FILE_OFFSET_BITS 64 +/* the define above will make off_t a 64bit type on GNU/Linux */ + +#include +#include + +#ifdef _AIX +/* needed to avoid conflicting declarations */ +#include +#include +#endif + #ifdef __vxworks #include "vxWorks.h" #endif @@ -106,16 +121,6 @@ __gnat_fileno (FILE *stream) return (fileno (stream)); } -int -__gnat_is_regular_file_fd (int fd) -{ - int ret; - GNAT_STRUCT_STAT statbuf; - - ret = GNAT_FSTAT (fd, &statbuf); - return (!ret && S_ISREG (statbuf.st_mode)); -} - /* on some systems, the constants for seek are not defined, if so, then provide the conventional definitions */ @@ -257,8 +262,8 @@ __gnat_full_name (char *nam, char *buffer) return buffer; } -#ifdef _WIN64 - /* On Windows 64 we want to use the fseek/fteel supporting large files. This +#ifdef _WIN32 + /* On Windows we want to use the fseek/fteel supporting large files. This issue is due to the fact that a long on Win64 is still a 32 bits value */ __int64 __gnat_ftell64 (FILE *stream) @@ -272,17 +277,46 @@ __gnat_fseek64 (FILE *stream, __int64 offset, int origin) return _fseeki64 (stream, offset, origin); } +#elif defined(linux) || defined(sun) \ + || defined (__FreeBSD__) || defined(__APPLE__) +/* section for platforms having ftello/fseeko */ + +__int64 +__gnat_ftell64 (FILE *stream) +{ + return (__int64)ftello (stream); +} + +int +__gnat_fseek64 (FILE *stream, __int64 offset, int origin) +{ + /* make sure that the offset is not bigger than the OS off_t, if so return + with error as this mean that we are trying to handle files larger than + 2Gb on a patform not supporting it. */ + if ((off_t)offset == offset) + return fseeko (stream, (off_t) offset, origin); + else + return -1; +} + #else -long + +__int64 __gnat_ftell64 (FILE *stream) { - return ftell (stream); + return (__int64)ftell (stream); } int -__gnat_fseek64 (FILE *stream, long offset, int origin) +__gnat_fseek64 (FILE *stream, __int64 offset, int origin) { - return fseek (stream, offset, origin); + /* make sure that the offset is not bigger than the OS off_t, if so return + with error as this mean that we are trying to handle files larger than + 2Gb on a patform not supporting it. */ + if ((off_t)offset == offset) + return fseek (stream, (off_t) offset, origin); + else + return -1; } #endif diff --git a/main/gcc/ada/debug.adb b/main/gcc/ada/debug.adb index 97277d61de4..94da7a6180e 100644 --- a/main/gcc/ada/debug.adb +++ b/main/gcc/ada/debug.adb @@ -49,7 +49,7 @@ package body Debug is -- dj Suppress "junk null check" for access parameter values -- dk Generate GNATBUG message on abort, even if previous errors -- dl Generate unit load trace messages - -- dm Allow VMS features even if not OpenVMS version + -- dm -- dn Generate messages for node/list allocation -- do Print source from tree (original code only) -- dp Generate messages for parser scope stack push/pops @@ -101,7 +101,7 @@ package body Debug is -- d.h -- d.i Ignore Warnings pragmas -- d.j Generate listing of frontend inlined calls - -- d.k Enable new support for frontend inlining + -- d.k -- 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 @@ -116,7 +116,7 @@ package body Debug is -- d.w Do not check for infinite loops -- d.x No exception handlers -- d.y - -- d.z + -- d.z Restore previous support for frontend handling of Inline_Always -- d.A Read/write Aspect_Specifications hash table to tree -- d.B @@ -141,9 +141,9 @@ package body Debug is -- d.U Ignore indirect calls for static elaboration -- d.V -- d.W Print out debugging information for Walk_Library_Items - -- d.X + -- d.X Old treatment of indexing aspects -- d.Y - -- d.Z + -- d.Z Do not enable expansion in configurable run-time mode -- d1 Error msgs have node numbers where possible -- d2 Eliminate error flags in verbose form error messages @@ -151,7 +151,7 @@ package body Debug is -- d4 Inhibit automatic krunch of predefined library unit files -- d5 Debug output for tree read/write -- d6 Default access unconstrained to thin pointers - -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode + -- d7 Suppress version/source stamp/compilation time for -gnatv/-gnatl -- d8 Force opposite endianness in packed stuff -- d9 Allow lock free implementation @@ -281,14 +281,6 @@ package body Debug is -- generated each time a request is made to the library manager to -- load a new unit. - -- dm Some features are permitted only in OpenVMS ports of GNAT (e.g. - -- the specification of passing by descriptor). Normally any use - -- of these features will be flagged as an error, but this debug - -- flag allows acceptance of these features in non OpenVMS ports. - -- Of course they may not have any useful effect, and in particular - -- attempting to generate code with this flag set may blow up. - -- The flag also forces the use of 64-bits for Long_Integer. - -- dn Generate messages for node/list allocation. Each time a node or -- list header is allocated, a line of output is generated. Certain -- other basic tree operations also cause a line of output to be @@ -541,9 +533,6 @@ package body Debug is -- to the backend. This is useful to locate skipped calls that must be -- inlined by the frontend. - -- d.k Enable new semantics of frontend inlining. This is useful to test - -- this new feature in all the platforms. - -- d.l Use Ada 95 semantics for limited function returns. This may be -- used to work around the incompatibility introduced by AI-318-2. -- It is useful only in -gnat05 mode. @@ -593,6 +582,13 @@ package body Debug is -- fully compiled and analyzed, they just get eliminated from the -- 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, .NET, JVM, 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. + -- 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 -- for now, this is controlled by the debug flag d.A. The hash table @@ -684,6 +680,18 @@ package body Debug is -- the order in which units are walked. This is primarily for use in -- debugging CodePeer mode. + -- d.X A previous version of GNAT allowed indexing aspects to be + -- redefined on derived container types, while the default iterator + -- was inherited from the aprent type. This non-standard extension + -- is preserved temporarily for use by the modelling project under + -- debug flag d.X. + + -- d.Z Normally we always enable expansion in configurable run-time mode + -- to make sure we get error messages about unsupported features even + -- when compiling in -gnatc mode. But expansion is turned off in this + -- case if debug flag -gnatd.Z is used. This is to deal with the case + -- where we discover difficulties in this new processing. + -- d1 Error messages have node numbers where possible. Normally error -- messages have only source locations. This option is useful when -- debugging errors caused by expanded code, where the source location @@ -716,10 +724,11 @@ package body Debug is -- implications of using thin pointers, and also to test that the -- compiler functions correctly with this choice. - -- d7 Normally a -gnatl or -gnatv listing includes the time stamp - -- of the source file. This debug flag suppresses this output, - -- and also suppresses the message with the version number. - -- This is useful in certain regression tests. + -- d7 Normally a -gnatl or -gnatv listing includes the time stamp of the + -- source file and the time of the compilation. This debug flag can + -- be used to suppress this output, and also suppresses the message + -- with the version of the compiler. This is useful for regression + -- tests which need to have consistent output. -- d8 This forces the packed stuff to generate code assuming the -- opposite endianness from the actual correct value. Useful in @@ -785,7 +794,9 @@ package body Debug is -- dn Do not delete temporary files created by gnatmake at the end -- of execution, such as temporary config pragma files, mapping - -- files or project path files. + -- files or project path files. This debug switch is equivalent to + -- the standard switch --keep-temp-files. We retain the debug switch + -- for back compatibility with past usage. -- dp Prints the Q used by routine Make.Compile_Sources every time -- we go around the main compile loop of Make.Compile_Sources @@ -807,9 +818,13 @@ package body Debug is -- Documentation for gprbuild Debug Flags -- --------------------------------------------- - -- dn Do not delete temporary files createed by gprbuild at the end + -- dm Display the maximum number of simultaneous compilations. + + -- dn Do not delete temporary files created by gprbuild at the end -- of execution, such as temporary config pragma files, mapping - -- files or project path files. + -- files or project path files. This debug switch is equivalent to + -- the standard switch --keep-temp-files. We retain the debug switch + -- for back compatibility with past usage. -- dt When a time stamp mismatch has been found for an ALI file, -- display the source file name, the time stamp expected and diff --git a/main/gcc/ada/einfo.adb b/main/gcc/ada/einfo.adb index 634d92acaea..c3b0f991966 100644 --- a/main/gcc/ada/einfo.adb +++ b/main/gcc/ada/einfo.adb @@ -115,7 +115,6 @@ package body Einfo is -- RM_Size Uint13 -- Alignment Uint14 - -- First_Optional_Parameter Node14 -- Normalized_Position Uint14 -- Shadow_Entities List14 @@ -195,7 +194,6 @@ package body Einfo is -- Component_Size Uint22 -- Corresponding_Remote_Type Node22 -- Enumeration_Rep_Expr Node22 - -- Exception_Code Uint22 -- Original_Record_Component Node22 -- Private_View Node22 -- Protected_Formal Node22 @@ -222,7 +220,8 @@ package body Einfo is -- DT_Offset_To_Top_Func Node25 -- PPC_Wrapper Node25 -- Related_Array_Object Node25 - -- Static_Predicate List25 + -- Static_Discrete_Predicate List25 + -- Static_Real_Or_String_Predicate Node25 -- Task_Body_Procedure Node25 -- Dispatch_Table_Wrappers Elist26 @@ -248,6 +247,7 @@ package body Einfo is -- Last_Aggregate_Assignment Node30 -- Static_Initialization Node30 + -- Derived_Type_Link Node31 -- Thunk_Entity Node31 -- SPARK_Pragma Node32 @@ -268,6 +268,9 @@ package body Einfo is -- sense for them to be set true for certain subsets of entity kinds. See -- the spec of Einfo for further details. + -- Is_Inlined_Always Flag1 + -- Is_Hidden_Non_Overridden_Subpgm Flag2 + -- Has_Default_Init_Cond Flag3 -- Is_Frozen Flag4 -- Has_Discriminants Flag5 -- Is_Dispatching_Operation Flag6 @@ -409,9 +412,9 @@ package body Einfo is -- Is_Generic_Instance Flag130 -- No_Pool_Assigned Flag131 - -- Is_AST_Entry Flag132 - -- Is_VMS_Exception Flag133 - -- Is_Optional_Parameter Flag134 + -- Is_Default_Init_Cond_Procedure Flag132 + -- Has_Inherited_Default_Init_Cond Flag133 + -- Returns_Limited_View Flag134 -- Has_Aliased_Components Flag135 -- No_Strict_Aliasing Flag136 -- Is_Machine_Code_Subprogram Flag137 @@ -562,14 +565,14 @@ package body Einfo is -- Has_Static_Predicate Flag269 -- Stores_Attribute_Old_Prefix Flag270 - -- (unused) Flag1 - -- (unused) Flag2 - -- (unused) Flag3 + -- (Has_Protected) Flag271 + -- (SSO_Set_Low_By_Default) Flag272 + -- (SSO_Set_High_By_Default) Flag273 + + -- Is_Generic_Actual_Subprogram Flag274 + -- No_Predicate_On_Actual Flag275 + -- No_Dynamic_Predicate_On_Actual Flag276 - -- (unused) Flag271 - -- (unused) Flag272 - -- (unused) Flag273 - -- (unused) Flag274 -- (unused) Flag275 -- (unused) Flag276 -- (unused) Flag277 @@ -947,6 +950,12 @@ package body Einfo is return Flag14 (Id); end Depends_On_Private; + function Derived_Type_Link (Id : E) return E is + begin + pragma Assert (Is_Type (Id)); + return Node31 (Base_Type (Id)); + end Derived_Type_Link; + function Digits_Value (Id : E) return U is begin pragma Assert @@ -1172,12 +1181,6 @@ package body Einfo is return Uint12 (Id); end Esize; - function Exception_Code (Id : E) return Uint is - begin - pragma Assert (Ekind (Id) = E_Exception); - return Uint22 (Id); - end Exception_Code; - function Extra_Accessibility (Id : E) return E is begin pragma Assert @@ -1259,12 +1262,6 @@ package body Einfo is return Node17 (Id); end First_Literal; - function First_Optional_Parameter (Id : E) return E is - begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); - return Node14 (Id); - end First_Optional_Parameter; - function First_Private_Entity (Id : E) return E is begin pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) @@ -1395,6 +1392,11 @@ package body Einfo is return Flag39 (Base_Type (Id)); end Has_Default_Aspect; + function Has_Default_Init_Cond (Id : E) return B is + begin + return Flag3 (Id); + end Has_Default_Init_Cond; + function Has_Delayed_Aspects (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -1479,6 +1481,12 @@ package body Einfo is return Flag248 (Id); end Has_Inheritable_Invariants; + function Has_Inherited_Default_Init_Cond (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag133 (Id); + end Has_Inherited_Default_Init_Cond; + function Has_Initial_Value (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Variable or else Is_Formal (Id)); @@ -1643,6 +1651,11 @@ package body Einfo is return Flag155 (Id); end Has_Private_Declaration; + function Has_Protected (Id : E) return B is + begin + return Flag271 (Base_Type (Id)); + end Has_Protected; + function Has_Qualified_Name (Id : E) return B is begin return Flag161 (Id); @@ -1886,12 +1899,6 @@ package body Einfo is return Flag15 (Id); end Is_Aliased; - function Is_AST_Entry (Id : E) return B is - begin - pragma Assert (Is_Entry (Id)); - return Flag132 (Id); - end Is_AST_Entry; - function Is_Asynchronous (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Procedure or else Is_Type (Id)); @@ -1977,6 +1984,12 @@ package body Einfo is return Flag74 (Id); end Is_CPP_Class; + function Is_Default_Init_Cond_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; + function Is_Descendent_Of_Address (Id : E) return B is begin return Flag223 (Id); @@ -2039,6 +2052,12 @@ package body Einfo is return Flag4 (Id); end Is_Frozen; + function Is_Generic_Actual_Subprogram (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag274 (Id); + end Is_Generic_Actual_Subprogram; + function Is_Generic_Actual_Type (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -2061,6 +2080,11 @@ package body Einfo is return Flag57 (Id); end Is_Hidden; + function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B is + begin + return Flag2 (Id); + end Is_Hidden_Non_Overridden_Subpgm; + function Is_Hidden_Open_Scope (Id : E) return B is begin return Flag171 (Id); @@ -2093,6 +2117,12 @@ package body Einfo is return Flag11 (Id); end Is_Inlined; + function Is_Inlined_Always (Id : E) return B is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + return Flag1 (Id); + end Is_Inlined_Always; + function Is_Interface (Id : E) return B is begin return Flag186 (Id); @@ -2122,7 +2152,7 @@ package body Einfo is function Is_Invariant_Procedure (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 Flag257 (Id); end Is_Invariant_Procedure; @@ -2190,12 +2220,6 @@ package body Einfo is return Flag226 (Id); end Is_Only_Out_Parameter; - function Is_Optional_Parameter (Id : E) return B is - begin - pragma Assert (Is_Formal (Id)); - return Flag134 (Id); - end Is_Optional_Parameter; - function Is_Package_Body_Entity (Id : E) return B is begin return Flag160 (Id); @@ -2267,7 +2291,7 @@ package body Einfo is function Is_Processed_Transient (Id : E) return B is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); return Flag252 (Id); end Is_Processed_Transient; @@ -2393,11 +2417,6 @@ package body Einfo is return Flag116 (Id); end Is_Visible_Lib_Unit; - function Is_VMS_Exception (Id : E) return B is - begin - return Flag133 (Id); - end Is_VMS_Exception; - function Is_Volatile (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -2547,12 +2566,24 @@ package body Einfo is return Node12 (Id); end Next_Inlined_Subprogram; + function No_Dynamic_Predicate_On_Actual (Id : E) return Boolean is + begin + pragma Assert (Is_Discrete_Type (Id)); + return Flag276 (Id); + end No_Dynamic_Predicate_On_Actual; + function No_Pool_Assigned (Id : E) return B is begin pragma Assert (Is_Access_Type (Id)); return Flag131 (Root_Type (Id)); end No_Pool_Assigned; + function No_Predicate_On_Actual (Id : E) return Boolean is + begin + pragma Assert (Is_Discrete_Type (Id)); + return Flag275 (Id); + end No_Predicate_On_Actual; + function No_Return (Id : E) return B is begin return Flag113 (Id); @@ -2839,6 +2870,12 @@ 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)); @@ -2965,11 +3002,29 @@ package body Einfo is return Node19 (Id); end Spec_Entity; - function Static_Predicate (Id : E) return S is + function SSO_Set_High_By_Default (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id)); + return Flag273 (Base_Type (Id)); + end SSO_Set_High_By_Default; + + function SSO_Set_Low_By_Default (Id : E) return B is + begin + pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id)); + return Flag272 (Base_Type (Id)); + end SSO_Set_Low_By_Default; + + function Static_Discrete_Predicate (Id : E) return S is begin pragma Assert (Is_Discrete_Type (Id)); return List25 (Id); - end Static_Predicate; + end Static_Discrete_Predicate; + + function Static_Real_Or_String_Predicate (Id : E) return N is + begin + pragma Assert (Is_Real_Type (Id) or else Is_String_Type (Id)); + return Node25 (Id); + end Static_Real_Or_String_Predicate; function Status_Flag_Or_Transient_Decl (Id : E) return N is begin @@ -3486,6 +3541,13 @@ package body Einfo is Set_Flag38 (Id, V); end Set_Can_Never_Be_Null; + procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is + begin + pragma Assert + (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id)); + Set_Flag229 (Id, V); + end Set_Can_Use_Internal_Rep; + procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True) is begin Set_Flag31 (Id, V); @@ -3527,6 +3589,22 @@ package body Einfo is Set_Node20 (Id, V); end Set_Component_Type; + procedure Set_Contract (Id : E; V : N) is + begin + pragma Assert + (Ekind_In (Id, E_Entry, + E_Entry_Family, + E_Generic_Package, + E_Package, + E_Package_Body, + E_Subprogram_Body, + E_Variable, + E_Void) + or else Is_Generic_Subprogram (Id) + or else Is_Subprogram (Id)); + Set_Node34 (Id, V); + end Set_Contract; + procedure Set_Corresponding_Concurrent_Type (Id : E; V : E) is begin pragma Assert @@ -3657,6 +3735,12 @@ package body Einfo is Set_Flag14 (Id, V); end Set_Depends_On_Private; + procedure Set_Derived_Type_Link (Id : E; V : E) is + begin + pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); + Set_Node31 (Id, V); + end Set_Derived_Type_Link; + procedure Set_Digits_Value (Id : E; V : U) is begin pragma Assert @@ -3811,22 +3895,6 @@ package body Einfo is Set_Node18 (Id, V); end Set_Entry_Index_Constant; - procedure Set_Contract (Id : E; V : N) is - begin - pragma Assert - (Ekind_In (Id, E_Entry, - E_Entry_Family, - E_Generic_Package, - E_Package, - E_Package_Body, - E_Subprogram_Body, - E_Variable, - E_Void) - or else Is_Generic_Subprogram (Id) - or else Is_Subprogram (Id)); - Set_Node34 (Id, V); - end Set_Contract; - procedure Set_Entry_Parameters_Type (Id : E; V : E) is begin Set_Node15 (Id, V); @@ -3873,12 +3941,6 @@ package body Einfo is Set_Uint12 (Id, V); end Set_Esize; - procedure Set_Exception_Code (Id : E; V : U) is - begin - pragma Assert (Ekind (Id) = E_Exception); - Set_Uint22 (Id, V); - end Set_Exception_Code; - procedure Set_Extra_Accessibility (Id : E; V : E) is begin pragma Assert @@ -3913,13 +3975,6 @@ package body Einfo is Set_Node28 (Id, V); end Set_Extra_Formals; - procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is - begin - pragma Assert - (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id)); - Set_Flag229 (Id, V); - end Set_Can_Use_Internal_Rep; - procedure Set_Finalization_Master (Id : E; V : E) is begin pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); @@ -3961,12 +4016,6 @@ package body Einfo is Set_Node17 (Id, V); end Set_First_Literal; - procedure Set_First_Optional_Parameter (Id : E; V : E) is - begin - pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); - Set_Node14 (Id, V); - end Set_First_Optional_Parameter; - procedure Set_First_Private_Entity (Id : E; V : E) is begin pragma Assert (Ekind_In (Id, E_Package, E_Generic_Package) @@ -4112,6 +4161,12 @@ 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 (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); @@ -4198,6 +4253,12 @@ package body Einfo is Set_Flag248 (Id, V); end Set_Has_Inheritable_Invariants; + procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag133 (Id, V); + end Set_Has_Inherited_Default_Init_Cond; + procedure Set_Has_Initial_Value (Id : E; V : B := True) is begin pragma Assert (Ekind_In (Id, E_Variable, E_Out_Parameter)); @@ -4372,6 +4433,11 @@ package body Einfo is Set_Flag155 (Id, V); end Set_Has_Private_Declaration; + procedure Set_Has_Protected (Id : E; V : B := True) is + begin + Set_Flag271 (Id, V); + end Set_Has_Protected; + procedure Set_Has_Qualified_Name (Id : E; V : B := True) is begin Set_Flag161 (Id, V); @@ -4621,12 +4687,6 @@ package body Einfo is Set_Flag15 (Id, V); end Set_Is_Aliased; - procedure Set_Is_AST_Entry (Id : E; V : B := True) is - begin - pragma Assert (Is_Entry (Id)); - Set_Flag132 (Id, V); - end Set_Is_AST_Entry; - procedure Set_Is_Asynchronous (Id : E; V : B := True) is begin pragma Assert @@ -4721,6 +4781,12 @@ 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 + begin + pragma Assert (Ekind (Id) = E_Procedure); + Set_Flag132 (Id, V); + end Set_Is_Default_Init_Cond_Procedure; + procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id)); @@ -4791,6 +4857,12 @@ package body Einfo is Set_Flag4 (Id, V); end Set_Is_Frozen; + procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag274 (Id, V); + end Set_Is_Generic_Actual_Subprogram; + procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id)); @@ -4813,6 +4885,12 @@ package body Einfo is Set_Flag57 (Id, V); end Set_Is_Hidden; + procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True) is + begin + pragma Assert (Ekind_In (Id, E_Function, E_Procedure)); + Set_Flag2 (Id, V); + end Set_Is_Hidden_Non_Overridden_Subpgm; + procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True) is begin Set_Flag171 (Id, V); @@ -4845,6 +4923,12 @@ package body Einfo is Set_Flag11 (Id, V); end Set_Is_Inlined; + procedure Set_Is_Inlined_Always (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + Set_Flag1 (Id, V); + end Set_Is_Inlined_Always; + procedure Set_Is_Interface (Id : E; V : B := True) is begin pragma Assert (Is_Record_Type (Id)); @@ -4875,7 +4959,7 @@ package body Einfo is procedure Set_Is_Invariant_Procedure (Id : E; V : B := True) is begin - pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure); + pragma Assert (Ekind (Id) = E_Procedure); Set_Flag257 (Id, V); end Set_Is_Invariant_Procedure; @@ -4945,12 +5029,6 @@ package body Einfo is Set_Flag226 (Id, V); end Set_Is_Only_Out_Parameter; - procedure Set_Is_Optional_Parameter (Id : E; V : B := True) is - begin - pragma Assert (Is_Formal (Id)); - Set_Flag134 (Id, V); - end Set_Is_Optional_Parameter; - procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is begin Set_Flag160 (Id, V); @@ -5023,7 +5101,7 @@ package body Einfo is procedure Set_Is_Processed_Transient (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Constant, E_Variable)); + pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable)); Set_Flag252 (Id, V); end Set_Is_Processed_Transient; @@ -5159,12 +5237,6 @@ package body Einfo is Set_Flag116 (Id, V); end Set_Is_Visible_Lib_Unit; - procedure Set_Is_VMS_Exception (Id : E; V : B := True) is - begin - pragma Assert (Ekind (Id) = E_Exception); - Set_Flag133 (Id, V); - end Set_Is_VMS_Exception; - procedure Set_Is_Volatile (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -5311,12 +5383,24 @@ package body Einfo is Set_Node12 (Id, V); end Set_Next_Inlined_Subprogram; + procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True) is + begin + pragma Assert (Is_Discrete_Type (Id)); + Set_Flag276 (Id, V); + end Set_No_Dynamic_Predicate_On_Actual; + procedure Set_No_Pool_Assigned (Id : E; V : B := True) is begin pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id)); Set_Flag131 (Id, V); end Set_No_Pool_Assigned; + procedure Set_No_Predicate_On_Actual (Id : E; V : B := True) is + begin + pragma Assert (Is_Discrete_Type (Id)); + Set_Flag275 (Id, V); + end Set_No_Predicate_On_Actual; + procedure Set_No_Return (Id : E; V : B := True) is begin pragma Assert @@ -5616,6 +5700,12 @@ 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 @@ -5750,11 +5840,34 @@ package body Einfo is Set_Node19 (Id, V); end Set_Spec_Entity; - procedure Set_Static_Predicate (Id : E; V : S) is + procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True) is + begin + pragma Assert + (Is_Base_Type (Id) + and then (Is_Record_Type (Id) or else Is_Array_Type (Id))); + Set_Flag273 (Id, V); + end Set_SSO_Set_High_By_Default; + + procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True) is + begin + pragma Assert + (Is_Base_Type (Id) + and then (Is_Record_Type (Id) or else Is_Array_Type (Id))); + Set_Flag272 (Id, V); + end Set_SSO_Set_Low_By_Default; + + procedure Set_Static_Discrete_Predicate (Id : E; V : S) is begin pragma Assert (Is_Discrete_Type (Id) and then Has_Predicates (Id)); Set_List25 (Id, V); - end Set_Static_Predicate; + end Set_Static_Discrete_Predicate; + + procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N) is + begin + pragma Assert ((Is_Real_Type (Id) or else Is_String_Type (Id)) + and then Has_Predicates (Id)); + Set_Node25 (Id, V); + end Set_Static_Real_Or_String_Predicate; procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is begin @@ -6342,6 +6455,31 @@ package body Einfo is end loop; end Declaration_Node; + --------------------------------- + -- Default_Init_Cond_Procedure -- + --------------------------------- + + function Default_Init_Cond_Procedure (Id : E) return E is + S : Entity_Id; + + begin + pragma Assert + (Is_Type (Id) + and then (Has_Default_Init_Cond (Id) + or Has_Inherited_Default_Init_Cond (Id))); + + S := Subprograms_For_Type (Id); + while Present (S) loop + if Is_Default_Init_Cond_Procedure (S) then + return S; + end if; + + S := Subprograms_For_Type (S); + end loop; + + return Empty; + end Default_Init_Cond_Procedure; + --------------------- -- Designated_Type -- --------------------- @@ -7126,17 +7264,39 @@ package body Einfo is end if; end Is_Standard_Character_Type; + ----------------------------- + -- Is_Standard_String_Type -- + ----------------------------- + + function Is_Standard_String_Type (Id : E) return B is + begin + if Is_Type (Id) then + declare + R : constant Entity_Id := Root_Type (Id); + begin + return + R = Standard_String + or else + R = Standard_Wide_String + or else + R = Standard_Wide_Wide_String; + end; + + else + return False; + end if; + end Is_Standard_String_Type; + -------------------- -- Is_String_Type -- -------------------- function Is_String_Type (Id : E) return B is begin - return Ekind (Id) in String_Kind - or else (Is_Array_Type (Id) - and then Id /= Any_Composite - and then Number_Dimensions (Id) = 1 - and then Is_Character_Type (Component_Type (Id))); + return Is_Array_Type (Id) + and then Id /= Any_Composite + and then Number_Dimensions (Id) = 1 + and then Is_Character_Type (Component_Type (Id)); end Is_String_Type; ------------------------------- @@ -7277,13 +7437,6 @@ package body Einfo is when others => return No_Uint; end case; - when VAX_Native => - case Digs is - when 1 .. 9 => return 2**7 - 1; - when 10 .. 15 => return 2**10 - 1; - when others => return No_Uint; - end case; - when AAMP => return Uint_2 ** Uint_7 - Uint_1; end case; @@ -7297,7 +7450,6 @@ package body Einfo is begin case Float_Rep (Id) is when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id); - when VAX_Native => return -Machine_Emax_Value (Id); when AAMP => return -Machine_Emax_Value (Id); end case; end Machine_Emin_Value; @@ -7320,14 +7472,6 @@ package body Einfo is when others => return No_Uint; end case; - when VAX_Native => - case Digs is - when 1 .. 6 => return Uint_24; - when 7 .. 9 => return UI_From_Int (56); - when 10 .. 15 => return UI_From_Int (53); - when others => return No_Uint; - end case; - when AAMP => case Digs is when 1 .. 6 => return Uint_24; @@ -7344,7 +7488,7 @@ package body Einfo is function Machine_Radix_Value (Id : E) return U is begin case Float_Rep (Id) is - when IEEE_Binary | VAX_Native | AAMP => + when IEEE_Binary | AAMP => return Uint_2; end case; end Machine_Radix_Value; @@ -7502,7 +7646,7 @@ package body Einfo is T : Node_Id; begin - if Ekind (Id) in String_Kind then + if Ekind (Id) = E_String_Literal_Subtype then return 1; else @@ -7510,7 +7654,7 @@ package body Einfo is T := First_Index (Id); while Present (T) loop N := N + 1; - T := Next (T); + Next_Index (T); end loop; return N; @@ -7786,7 +7930,6 @@ package body Einfo is (Num => Significand * 2 ** (Exponent mod 4), Den => -Exponent / 4, Rbase => 16); - else return UR_From_Components @@ -7862,6 +8005,34 @@ package body Einfo is end case; end Set_Component_Alignment; + ------------------------------------- + -- Set_Default_Init_Cond_Procedure -- + ------------------------------------- + + procedure Set_Default_Init_Cond_Procedure (Id : E; V : E) is + S : Entity_Id; + + begin + pragma Assert + (Is_Type (Id) and then (Has_Default_Init_Cond (Id) + or + Has_Inherited_Default_Init_Cond (Id))); + + S := Subprograms_For_Type (Id); + Set_Subprograms_For_Type (Id, V); + Set_Subprograms_For_Type (V, S); + + -- Check for a duplicate procedure + + while Present (S) loop + if Is_Default_Init_Cond_Procedure (S) then + raise Program_Error; + end if; + + S := Subprograms_For_Type (S); + end loop; + end Set_Default_Init_Cond_Procedure; + ----------------------------- -- Set_Invariant_Procedure -- ----------------------------- @@ -7997,10 +8168,6 @@ package body Einfo is E_Record_Subtype => Kind := E_Record_Subtype; - when E_String_Type | - E_String_Subtype => - Kind := E_String_Subtype; - when Enumeration_Kind => Kind := E_Enumeration_Subtype; @@ -8071,7 +8238,7 @@ package body Einfo is elsif Ekind (Id) in Incomplete_Or_Private_Kind then -- If we have an incomplete or private type with a full view, - -- then we return the Underlying_Type of this full view + -- then we return the Underlying_Type of this full view. if Present (Full_View (Id)) then if Id = Full_View (Id) then @@ -8084,6 +8251,14 @@ package body Einfo is return Underlying_Type (Full_View (Id)); end if; + -- If we have a private type with an underlying full view, then we + -- return the Underlying_Type of this underlying full view. + + elsif Ekind (Id) in Private_Kind + and then Present (Underlying_Full_View (Id)) + then + return Underlying_Type (Underlying_Full_View (Id)); + -- If we have an incomplete entity that comes from the limited -- view then we return the Underlying_Type of its non-limited -- view. @@ -8108,24 +8283,14 @@ package body Einfo is return Empty; end if; - -- For non-incomplete, non-private types, return the type itself - -- Also for entities that are not types at all return the entity - -- itself. + -- For non-incomplete, non-private types, return the type itself Also + -- for entities that are not types at all return the entity itself. else return Id; end if; end Underlying_Type; - --------------- - -- Vax_Float -- - --------------- - - function Vax_Float (Id : E) return B is - begin - return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native; - end Vax_Float; - ------------------------ -- Write_Entity_Flags -- ------------------------ @@ -8207,6 +8372,7 @@ 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)); @@ -8222,6 +8388,7 @@ 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_Initial_Value", Flag219 (Id)); W ("Has_Invariants", Flag232 (Id)); W ("Has_Loop_Entry_Attributes", Flag260 (Id)); @@ -8252,6 +8419,7 @@ package body Einfo is W ("Has_Primitive_Operations", Flag120 (Id)); W ("Has_Private_Ancestor", Flag151 (Id)); W ("Has_Private_Declaration", Flag155 (Id)); + W ("Has_Protected", Flag271 (Id)); W ("Has_Qualified_Name", Flag161 (Id)); W ("Has_RACW", Flag214 (Id)); W ("Has_Record_Rep_Clause", Flag65 (Id)); @@ -8280,10 +8448,8 @@ package body Einfo is W ("In_Package_Body", Flag48 (Id)); W ("In_Private_Part", Flag45 (Id)); W ("In_Use", Flag8 (Id)); - W ("Is_AST_Entry", Flag132 (Id)); W ("Is_Abstract_Subprogram", Flag19 (Id)); - W ("Is_Abstract_Type", Flag146 (Id)); - W ("Is_Local_Anonymous_Access", Flag194 (Id)); + W ("Is_Abstract_Type", Flag146 (Id)); W ("Is_Access_Constant", Flag69 (Id)); W ("Is_Ada_2005_Only", Flag185 (Id)); W ("Is_Ada_2012_Only", Flag199 (Id)); @@ -8305,6 +8471,7 @@ 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_Discrim_SO_Function", Flag176 (Id)); W ("Is_Discriminant_Check_Function", Flag264 (Id)); @@ -8317,16 +8484,19 @@ package body Einfo is W ("Is_For_Access_Subtype", Flag118 (Id)); W ("Is_Formal_Subprogram", Flag111 (Id)); W ("Is_Frozen", Flag4 (Id)); + W ("Is_Generic_Actual_Subprogram", Flag274 (Id)); W ("Is_Generic_Actual_Type", Flag94 (Id)); W ("Is_Generic_Instance", Flag130 (Id)); W ("Is_Generic_Type", Flag13 (Id)); W ("Is_Hidden", Flag57 (Id)); + W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id)); W ("Is_Hidden_Open_Scope", Flag171 (Id)); W ("Is_Immediately_Visible", Flag7 (Id)); W ("Is_Implementation_Defined", Flag254 (Id)); W ("Is_Imported", Flag24 (Id)); W ("Is_Independent", Flag268 (Id)); W ("Is_Inlined", Flag11 (Id)); + W ("Is_Inlined_Always", Flag1 (Id)); W ("Is_Instantiated", Flag126 (Id)); W ("Is_Interface", Flag186 (Id)); W ("Is_Internal", Flag17 (Id)); @@ -8340,12 +8510,12 @@ package body Einfo is W ("Is_Limited_Composite", Flag106 (Id)); W ("Is_Limited_Interface", Flag197 (Id)); W ("Is_Limited_Record", Flag25 (Id)); + W ("Is_Local_Anonymous_Access", Flag194 (Id)); W ("Is_Machine_Code_Subprogram", Flag137 (Id)); W ("Is_Non_Static_Subtype", Flag109 (Id)); W ("Is_Null_Init_Proc", Flag178 (Id)); W ("Is_Obsolescent", Flag153 (Id)); W ("Is_Only_Out_Parameter", Flag226 (Id)); - W ("Is_Optional_Parameter", Flag134 (Id)); W ("Is_Package_Body_Entity", Flag160 (Id)); W ("Is_Packed", Flag51 (Id)); W ("Is_Packed_Array_Impl_Type", Flag138 (Id)); @@ -8379,7 +8549,6 @@ package body Einfo is W ("Is_Unchecked_Union", Flag117 (Id)); W ("Is_Underlying_Record_View", Flag246 (Id)); W ("Is_Unsigned_Type", Flag144 (Id)); - W ("Is_VMS_Exception", Flag133 (Id)); W ("Is_Valued_Procedure", Flag127 (Id)); W ("Is_Visible_Formal", Flag206 (Id)); W ("Is_Visible_Lib_Unit", Flag116 (Id)); @@ -8397,7 +8566,9 @@ package body Einfo is W ("Needs_Debug_Info", Flag147 (Id)); W ("Needs_No_Actuals", Flag22 (Id)); W ("Never_Set_In_Source", Flag115 (Id)); + W ("No_Dynamic_Predicate_On_actual", Flag276 (Id)); W ("No_Pool_Assigned", Flag131 (Id)); + W ("No_Predicate_On_actual", Flag275 (Id)); W ("No_Return", Flag113 (Id)); W ("No_Strict_Aliasing", Flag136 (Id)); W ("Non_Binary_Modulus", Flag58 (Id)); @@ -8415,6 +8586,7 @@ 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 ("Sec_Stack_Needed_For_Return", Flag167 (Id)); @@ -8422,6 +8594,8 @@ package body Einfo is W ("Size_Known_At_Compile_Time", Flag92 (Id)); W ("SPARK_Aux_Pragma_Inherited", Flag266 (Id)); W ("SPARK_Pragma_Inherited", Flag265 (Id)); + W ("SSO_Set_High_By_Default", Flag273 (Id)); + W ("SSO_Set_Low_By_Default", Flag272 (Id)); W ("Static_Elaboration_Desired", Flag77 (Id)); W ("Stores_Attribute_Old_Prefix", Flag270 (Id)); W ("Strict_Alignment", Flag145 (Id)); @@ -8821,10 +8995,6 @@ package body Einfo is E_Loop_Parameter => Write_Str ("Alignment"); - when E_Function | - E_Procedure => - Write_Str ("First_Optional_Parameter"); - when E_Component | E_Discriminant => Write_Str ("Normalized_Position"); @@ -9230,9 +9400,6 @@ package body Einfo is when E_Enumeration_Literal => Write_Str ("Enumeration_Rep_Expr"); - when E_Exception => - Write_Str ("Exception_Code"); - when E_Record_Type_With_Private | E_Record_Subtype_With_Private | E_Private_Type | @@ -9387,12 +9554,11 @@ package body Einfo is E_Entry_Family => Write_Str ("PPC_Wrapper"); - when E_Enumeration_Type | - E_Enumeration_Subtype | - E_Modular_Integer_Type | - E_Modular_Integer_Subtype | - E_Signed_Integer_Subtype => - Write_Str ("Static_Predicate"); + when Discrete_Kind => + Write_Str ("Static_Discrete_Predicate"); + + when Real_Kind => + Write_Str ("Static_Real_Or_String_Predicate"); when others => Write_Str ("Field25??"); @@ -9546,6 +9712,9 @@ package body Einfo is E_Function => Write_Str ("Thunk_Entity"); + when Type_Kind => + Write_Str ("Derived_Type_Link"); + when others => Write_Str ("Field31??"); end case; diff --git a/main/gcc/ada/einfo.ads b/main/gcc/ada/einfo.ads index 3422ac0455c..d75beccb0ee 100644 --- a/main/gcc/ada/einfo.ads +++ b/main/gcc/ada/einfo.ads @@ -47,10 +47,10 @@ package Einfo is -- and they correspond to conventional symbol table information. Other -- attributes include sets of meanings for overloaded names, possible -- types for overloaded expressions, flags to indicate deferred constants, --- incomplete types, etc. These attributes are stored in available fields --- in tree nodes (i.e. fields not used by the parser, as defined by the --- Sinfo package specification), and accessed by means of a set of --- subprograms which define an abstract interface. +-- incomplete types, etc. These attributes are stored in available fields in +-- tree nodes (i.e. fields not used by the parser, as defined by the Sinfo +-- package specification), and accessed by means of a set of subprograms +-- which define an abstract interface. -- There are two kinds of semantic information @@ -82,10 +82,9 @@ package Einfo is -------------------------------- -- XEINFO is a utility program which automatically produces a C header file, --- einfo.h from the spec and body of package Einfo. It reads the input --- files einfo.ads and einfo.adb and produces the output file einfo.h. --- XEINFO is run automatically by the build scripts when you do a full --- bootstrap. +-- einfo.h from the spec and body of package Einfo. It reads the input files +-- einfo.ads and einfo.adb and produces the output file einfo.h. XEINFO is run +-- automatically by the build scripts when you do a full bootstrap. -- In order for this utility program to operate correctly, the form of the -- einfo.ads and einfo.adb files must meet certain requirements and be laid @@ -302,13 +301,13 @@ package Einfo is -- access functions and set procedures to set the corresponding values, while -- synthesized attributes have only access functions. --- Note: in the case of Node, Uint, or Elist fields, there are cases where --- the same physical field is used for different purposes in different --- entities, so these access functions should only be referenced for the --- class of entities in which they are defined as being present. Flags are --- not overlapped in this way, but nevertheless as a matter of style and --- abstraction (which may or may not be checked by assertions in the body), --- this restriction should be observed for flag fields as well. +-- Note: in the case of Node, Uint, or Elist fields, there are cases where the +-- same physical field is used for different purposes in different entities, +-- so these access functions should only be referenced for the class of +-- entities in which they are defined as being present. Flags are not +-- overlapped in this way, but nevertheless as a matter of style and +-- abstraction (which may or may not be checked by assertions in the +-- body), this restriction should be observed for flag fields as well. -- Note: certain of the attributes on types apply only to base types, and -- are so noted by the notation [base type only]. These are cases where the @@ -352,7 +351,7 @@ package Einfo is -- defined primitives, and 6) secondary dispatch table with predefined -- primitives. The last entity of this list is an access type declaration -- used to expand dispatching calls through the primary dispatch table. --- For a non-tagged record, contains No_Elist. +-- For an untagged record, contains No_Elist. -- Actual_Subtype (Node17) -- Defined in variables, constants, and formal parameters. This is the @@ -390,8 +389,8 @@ package Einfo is -- case of subprograms to control output of certain warnings. -- Aft_Value (synthesized) --- Applies to fixed and decimal types. Computes a universal integer --- that holds value of the Aft attribute for the type. +-- Applies to fixed and decimal types. Computes a universal integer that +-- holds value of the Aft attribute for the type. -- Alias (Node18) -- Defined in overloadable entities (literals, subprograms, entries) and @@ -584,7 +583,7 @@ package Einfo is -- Class_Wide_Type (Node9) -- Defined in all type entities. For a tagged type or subtype, returns -- the corresponding implicitly declared class-wide type. For a --- class-wide type, returns itself. Set to Empty for non-tagged types. +-- class-wide type, returns itself. Set to Empty for untagged types. -- Cloned_Subtype (Node16) -- Defined in E_Record_Subtype and E_Class_Wide_Subtype entities. @@ -773,6 +772,16 @@ 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 @@ -819,6 +828,28 @@ package Einfo is -- Defined in all type entities. Set if the type is private or if it -- depends on a private type. +-- Derived_Type_Link (Node31) +-- Defined in all type and subtype entries. Set in a base type if +-- a derived type declaration is encountered which derives from +-- this base type or one of its subtypes, and there are already +-- primitive operations declared. In this case, it references the +-- entity for the type declared by the derived type declaration. +-- For example: +-- +-- type R is ... +-- subtype RS is R ... +-- ... +-- type G is new RS ... +-- +-- In this case, if primitive operations have been declared for R, at +-- the point of declaration of G, then the Derived_Type_Link of R is set +-- to point to the entity for G. This is used to generate warnings for +-- rep clauses that appear later on for R, which might result in an +-- unexpected implicit conversion operation. +-- +-- Note: if there is more than one such derived type, the link will point +-- to the last one (this is only used in generating warning messages). + -- Designated_Type (synthesized) -- Applies to access types. Returns the designated type. Differs from -- Directly_Designated_Type in that if the access type refers to an @@ -915,7 +946,7 @@ package Einfo is -- Defined in E_Record_Type and E_Record_Subtype entities. Set in library -- level tagged type entities if we are generating statically allocated -- dispatch tables. Points to the list of dispatch table wrappers --- associated with the tagged type. For a non-tagged record, contains +-- associated with the tagged type. For an untagged record, contains -- No_Elist. -- DTC_Entity (Node16) @@ -1127,13 +1158,6 @@ package Einfo is -- Note one obscure case: for pragma Default_Storage_Pool (null), the -- Etype of the N_Null node is Empty. --- Exception_Code (Uint22) --- Defined in exception entities. Set to zero unless either an --- Import_Exception or Export_Exception pragma applies to the --- pragma and specifies a Code value. See description of these --- pragmas for details. Note that this field is relevant only if --- Is_VMS_Exception is set. - -- Extra_Formal (Node15) -- Defined in formal parameters in the non-generic case. Certain -- parameters require extra implicit information to be passed (e.g. the @@ -1245,14 +1269,14 @@ package Einfo is -- all the extra formals (see description of Extra_Formals field). -- First_Index (Node17) --- Defined in array types and subtypes and in string types and subtypes. --- By introducing implicit subtypes for the index constraints, we have --- the same structure for constrained and unconstrained arrays, subtype --- marks and discrete ranges are both represented by a subtype. This --- function returns the tree node corresponding to an occurrence of the --- first index (NOT the entity for the type). Subsequent indices are --- obtained using Next_Index. Note that this field is defined for the --- case of string literal subtypes, but is always Empty. +-- Defined in array types and subtypes. By introducing implicit subtypes +-- for the index constraints, we have the same structure for constrained +-- and unconstrained arrays, subtype marks and discrete ranges are +-- both represented by a subtype. This function returns the tree node +-- corresponding to an occurrence of the first index (NOT the entity for +-- the type). Subsequent indices are obtained using Next_Index. Note that +-- this field is defined for the case of string literal subtypes, but is +-- always Empty. -- First_Literal (Node17) -- Defined in all enumeration types, including character and boolean @@ -1264,13 +1288,6 @@ package Einfo is -- Note that this field is set in enumeration subtypes, but it still -- points to the first literal of the base type in this case. --- First_Optional_Parameter (Node14) --- Defined in (non-generic) function and procedure entities. Set to a --- non-null value only if a pragma Import_Function, Import_Procedure --- or Import_Valued_Procedure specifies a First_Optional_Parameter --- argument, in which case this field points to the parameter entity --- corresponding to the specified parameter. - -- First_Private_Entity (Node16) -- Defined in all entities containing private parts (packages, protected -- types and subtypes, task types and subtypes). The entities on the @@ -1467,6 +1484,17 @@ package Einfo is -- Convention, Import, or Export has been given. Used to prevent more -- than one such pragma appearing for a given entity (RM B.1(45)). +-- Has_Default_Aspect (Flag39) [base type only] +-- Defined in entities for types and subtypes, set for scalar types with +-- a Default_Value aspect and array types with a Default_Component_Value +-- apsect. If this flag is set, then a corresponding aspect specification +-- node will be present on the rep item chain for the entity. + +-- Has_Default_Init_Cond (Flag3) +-- Defined in type and subtype entities. Set if pragma Default_Initial_ +-- Condition applies to the type or subtype. This flag must be mutually +-- exclusive with 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 @@ -1479,12 +1507,6 @@ package Einfo is -- node must be generated for the entity at its freezing point. See -- separate section ("Delayed Freezing and Elaboration") for details. --- Has_Default_Aspect (Flag39) [base type only] --- Defined in entities for types and subtypes, set for scalar types with --- a Default_Value aspect and array types with a Default_Component_Value --- apsect. If this flag is set, then a corresponding aspect specification --- node will be present on the rep item chain for the entity. - -- Has_Delayed_Rep_Aspects (Flag261) -- Defined in all type and subtypes. This flag is set if there is at -- least one aspect for a representation characteristic that has to be @@ -1598,6 +1620,11 @@ package Einfo is -- type which has inheritable invariants, and in this case the flag will -- also be set in the private type. +-- Has_Inherited_Default_Init_Cond (Flag133) +-- Defined in type and subtype entities. Set if a derived type inherits +-- pragma Default_Initial_Condition from its parent type. This flag must +-- be mutually exclusive with Had_Default_Init_Cond. + -- Has_Initial_Value (Flag219) -- Defined in entities for variables and out parameters. Set if there -- is an explicit initial value expression in the declaration of the @@ -1792,14 +1819,12 @@ package Einfo is -- is defined for the type. -- Has_Private_Ancestor (Flag151) --- Applies to untagged derived types and to type extensions. True when --- some ancestor is derived from a private type, making some components --- invisible and aggregates illegal. Used to check the legality of --- selected components and aggregates. The flag is set at the point of --- derivation. The legality of an aggregate of a type with a private --- ancestor must be checked because it also depends on the visibility --- at the point the aggregate is resolved. See sem_aggr.adb. This is --- part of AI05-0115. +-- Applies to type extensions. True if some ancestor is derived from a +-- private type, making some components invisible and aggregates illegal. +-- This flag is set at the point of derivation. The legality of the +-- aggregate must be rechecked because it also depends on the visibility +-- at the point the aggregate is resolved. See sem_aggr.adb. This is part +-- of AI05-0115. -- Has_Private_Declaration (Flag155) -- Defined in all entities. Set if it is the defining entity of a private @@ -1808,6 +1833,14 @@ package Einfo is -- indicate if a full type declaration is a completion. Used for semantic -- checks in E.4(18) and elsewhere. +-- 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. + -- Has_Qualified_Name (Flag161) -- Defined in all entities. Set if the name in the Chars field has -- been replaced by its qualified name, as used for debug output. See @@ -1878,13 +1911,13 @@ package Einfo is -- include only the components corresponding to these discriminants. -- Has_Static_Predicate (Flag269) --- Defined in all types and subtypes. Set if the type (which must be --- a discrete, real, or string subtype) has a static predicate, i.e. a --- predicate whose expression is predicate-static. This can result from --- use of a Predicate, Static_Predicate, or Dynamic_Predicate aspect. We --- can distinguish these cases by testing Has_Static_Predicate_Aspect --- and Has_Dynamic_Predicate_Aspect. See description of the latter flag --- for further information on dynamic predicates which are also static. +-- Defined in all types and subtypes. Set if the type (which must be a +-- scalar type) has a predicate whose expression is predicate-static. +-- This can result from the use of any Predicate, Static_Predicate, or +-- Dynamic_Predicate aspect. We can distinguish these cases by testing +-- Has_Static_Predicate_Aspect and Has_Dynamic_Predicate_Aspect. See +-- description of the latter flag for further information on dynamic +-- predicates which are also static. -- Has_Static_Predicate_Aspect (Flag259) -- Defined in all types and subtypes. Set if a Static_Predicate aspect @@ -1925,9 +1958,9 @@ package Einfo is -- Defined in all type entities. Set on unchecked unions themselves -- and (recursively) on any composite type which has a component for -- which Has_Unchecked_Union is set. The meaning is that a comparison --- operation for the type is not permitted. Note that the flag is not --- set on access types, even if they designate an object that has --- the flag Has_Unchecked_Union set. +-- operation or 'Valid_Scalars reference for the type is not permitted. +-- Note that the flag is not set on access types, even if they designate +-- an object that has the flag Has_Unchecked_Union set. -- Has_Unknown_Discriminants (Flag72) -- Defined in all entities. Set for types with unknown discriminants. @@ -2039,13 +2072,11 @@ package Einfo is -- access to subprograms (JGNAT only). Set to Empty unless an export, -- import, or interface name pragma has explicitly specified an external -- name, in which case it references an N_String_Literal node for the --- specified external name. In the case of exceptions, the field is set --- by Import_Exception/Export_Exception (which can be used in OpenVMS --- versions only). Note that if this field is Empty, and Is_Imported --- or Is_Exported is set, then the default interface name is the name --- of the entity, cased in a manner that is appropriate to the system --- in use. Note that Interface_Name is ignored if an address clause --- is present (since it is meaningless in this case). +-- specified external name. Note that if this field is Empty, and +-- Is_Imported or Is_Exported is set, then the default interface name +-- is the name of the entity, cased in a manner that is appropriate to +-- the system in use. Note that Interface_Name is ignored if an address +-- clause is present (since it is meaningless in this case). -- -- An additional special case usage of this field is in JGNAT for -- E_Component and E_Discriminant. JGNAT allows these entities to be @@ -2119,13 +2150,6 @@ package Einfo is -- carry the keyword aliased, and on record components that have the -- keyword. For Ada 2012, also applies to formal parameters. --- Is_AST_Entry (Flag132) --- Defined in entry entities. Set if a valid pragma AST_Entry applies --- to the entry. This flag can only be set in OpenVMS versions of GNAT. --- Note: we also allow the flag to appear in entry families, but given --- the current implementation of the pragma AST_Entry, this flag will --- always be False in entry families. - -- Is_Atomic (Flag85) -- Defined in all type entities, and also in constants, components and -- variables. Set if a pragma Atomic or Shared applies to the entity. @@ -2251,6 +2275,10 @@ 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) -- Defined in all entities. True if the entity is type System.Address, -- or (recursively) a subtype or derived type of System.Address. @@ -2315,7 +2343,7 @@ package Einfo is -- Defined in all entities. Set if the entity is exported. For now we -- only allow the export of constants, exceptions, functions, procedures -- and variables, but that may well change later on. Exceptions can only --- be exported in the OpenVMS and Java VM implementations of GNAT. +-- be exported in the Java VM implementation of GNAT. -- Is_External_State (synthesized) -- Applies to all entities, true for abstract states that are subject to @@ -2359,10 +2387,24 @@ package Einfo is -- Defined in all type and subtype entities. Set if type or subtype has -- been frozen. +-- Is_Generic_Actual_Subprogram (Flag274) +-- Defined on functions and procedures. Set on the entity of the renaming +-- declaration created within an instance for an actual subprogram. +-- Used to generate constraint checks on calls to these subprograms, even +-- within an instance of a predefined run-time unit, in which checks +-- are otherwise suppressed. +-- +-- The flag is also set on the entity of the expression function created +-- within an instance, for a function that has external axiomatization, +-- for use in GNATprove mode. + -- Is_Generic_Actual_Type (Flag94) -- Defined in all type and subtype entities. Set in the subtype -- declaration that renames the generic formal as a subtype of the -- actual. Guarantees that the subtype is not static within the instance. +-- Also used during analysis of an instance, to simplify resolution of +-- accidental overloading that occurs when different formal types get the +-- same actual. -- Is_Generic_Instance (Flag130) -- Defined in all entities. Set to indicate that the entity is an @@ -2405,6 +2447,12 @@ package Einfo is -- child unit, and when compiling a private child unit (see Install_ -- Private_Declaration in sem_ch7). +-- Is_Hidden_Non_Overridden_Subpgm (Flag2) +-- Defined in all entities. Set for implicitly declared subprograms +-- that require overriding or are null procedures, and are hidden by +-- a non-fully conformant homograph with the same characteristics +-- (Ada RM 8.3 12.3/2). + -- Is_Hidden_Open_Scope (Flag171) -- Defined in all entities. Set for a scope that contains the -- instantiation of a child unit, and whose entities are not visible @@ -2423,9 +2471,8 @@ package Einfo is -- Is_Imported (Flag24) -- Defined in all entities. Set if the entity is imported. For now we -- only allow the import of exceptions, functions, procedures, packages. --- and variables. Exceptions can only be imported in the OpenVMS and --- Java VM implementations of GNAT. Packages and types can only be --- imported in the Java VM implementation. +-- and variables. Exceptions, packages and types can only be imported in +-- the Java VM implementation. -- Is_Incomplete_Or_Private_Type (synthesized) -- Applies to all entities, true for private and incomplete types @@ -2447,6 +2494,12 @@ package Einfo is -- inherited by their instances. It is also set on the body entities -- of inlined subprograms. See also Has_Pragma_Inline. +-- Is_Inlined_Always (Flag1) +-- Defined in subprograms. Set for functions and procedures which are +-- always inlined in GNATprove mode. GNATprove uses this flag to know +-- when a body does not need to be analyzed. The value of this flag is +-- only meaningful if Body_To_Inline is not Empty for the subprogram. + -- Is_Instantiated (Flag126) -- Defined in generic packages and generic subprograms. Set if the unit -- is instantiated from somewhere in the extended main source unit. This @@ -2667,11 +2720,6 @@ package Einfo is -- out parameter, or if there is some other IN OUT parameter then this -- flag is not set in any of them. Used in generation of warnings. --- Is_Optional_Parameter (Flag134) --- Defined in parameter entities. Set if the parameter is specified as --- optional by use of a First_Optional_Parameter argument to one of the --- extended Import pragmas. Can only be set for OpenVMS versions of GNAT. - -- Is_Ordinary_Fixed_Point_Type (synthesized) -- Applies to all entities, true for ordinary fixed point types and -- subtypes. @@ -2759,7 +2807,7 @@ package Einfo is -- Is_Primitive (Flag218) -- Defined in overloadable entities and in generic subprograms. Set to -- indicate that this is a primitive operation of some type, which may --- be a tagged type or a non-tagged type. Used to verify overriding +-- be a tagged type or an untagged type. Used to verify overriding -- indicators in bodies. -- Is_Primitive_Wrapper (Flag195) @@ -2796,10 +2844,11 @@ package Einfo is -- as well as for record with private types as subtypes -- Is_Processed_Transient (Flag252) --- Defined in entities of variables and constants. Set when a transient --- object needs to be finalized and it has already been processed by the --- transient scope machinery. This flag signals the general finalization --- mechanism to ignore the transient object. +-- 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 @@ -2891,9 +2940,14 @@ package Einfo is -- Is_Standard_Character_Type (synthesized) -- Applies to all entities, true for types and subtypes whose root type --- is one of the standard character types (Character, Wide_Character, +-- is one of the standard character types (Character, Wide_Character, or -- Wide_Wide_Character). +-- Is_Standard_String_Type (synthesized) +-- Applies to all entities, true for types and subtypes whose root +-- type is one of the standard string types (String, Wide_String, or +-- Wide_Wide_String). + -- Is_Statically_Allocated (Flag28) -- Defined in all entities. This can only be set for exception, -- variable, constant, and type/subtype entities. If the flag is set, @@ -3016,12 +3070,6 @@ package Einfo is -- a separate flag must be used to indicate whether the names are visible -- by selected notation, or not. --- Is_VMS_Exception (Flag133) --- Defined in all entities. Set only for exception entities where the --- exception was specified in an Import_Exception or Export_Exception --- pragma with the VMS option for Form. See description of these pragmas --- for details. This flag can only be set in OpenVMS versions of GNAT. - -- Is_Volatile (Flag16) -- Defined in all type entities, and also in constants, components and -- variables. Set if a pragma Volatile applies to the entity. Also set @@ -3164,9 +3212,9 @@ package Einfo is -- Mechanism (Uint8) (returned as Mechanism_Type) -- Defined in functions and non-generic formal parameters. Indicates -- the mechanism to be used for the function return or for the formal --- parameter. See separate section on passing mechanisms. This field --- is also set (to the default value of zero) in a subprogram body --- entity but not used in this context. +-- parameter. See full description in the spec of Sem_Mech. This field +-- is also set (to the default value of zero = Default_Mechanism) in a +-- subprogram body entity but not used in this context. -- Modulus (Uint17) [base type only] -- Defined in modular types. Contains the modulus. For the binary case, @@ -3323,6 +3371,11 @@ package Einfo is -- interpreted as true. Currently this is set for derived Boolean -- types which have a convention of C, C++ or Fortran. +-- No_Dynamic_Predicate_On_Actual (Flag276) +-- Defined in discrete types. Set for generic formal types that are used +-- in loops and quantified expressions. The corresponing actual cannot +-- have dynamic predicates. + -- No_Pool_Assigned (Flag131) [root type only] -- Defined in access types. Set if a storage size clause applies to the -- variable with a static expression value of zero. This flag is used to @@ -3330,6 +3383,11 @@ package Einfo is -- of such an access type. This is set only in the root type, since -- derived types must have the same pool. +-- No_Predicate_On_Actual (Flag275) +-- Defined in discrete types. Set for generic formal types that are used +-- in the spec of a generic package, in constructs that forbid discrete +-- types with predicates. + -- No_Return (Flag113) -- Defined in all entities. Always false except in the case of procedures -- and generic procedures for which a pragma No_Return is given. @@ -3438,7 +3496,7 @@ package Einfo is -- -- Rec_Ext.Comp -> Rec_Ext.Parent. ... .Parent.Comp -- --- In base non-tagged types: +-- In base untagged types: -- Always points to itself except for non-girder discriminants, where -- it points to the girder discriminant it renames. -- @@ -3714,9 +3772,15 @@ package Einfo is -- even though it causes the whole function to return. -- Returns_By_Ref (Flag90) --- Defined in function entities, to indicate that the function --- returns the result by reference, either because its return type is a --- by-reference-type or because it uses explicitly the secondary stack. +-- Defined in function entities. Set if the function returns the result +-- 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 @@ -3889,9 +3953,19 @@ package Einfo is -- case where there is a separate spec, where this field references -- the corresponding parameter entities in the spec. --- Static_Predicate (List25) +-- SSO_Set_High_By_Default (Flag273) [base type only] +-- Defined for record and array types. Set in the base type if a pragma +-- Default_Scalar_Storage_Order (High_Order_First) was active at the time +-- the record or array was declared and therefore applies to it. + +-- SSO_Set_Low_By_Default (Flag272) [base type only] +-- Defined for record and array types. Set in the base type if a pragma +-- Default_Scalar_Storage_Order (High_Order_First) was active at the time +-- the record or array was declared and therefore applies to it. + +-- Static_Discrete_Predicate (List25) -- Defined in discrete types/subtypes with static predicates (with the --- two flags Has_Predicates set and Has_Static_Predicate set). Set if the +-- two flags Has_Predicates and Has_Static_Predicate set). Set if the -- type/subtype has a static predicate. Points to a list of expression -- and N_Range nodes that represent the predicate in canonical form. The -- canonical form has entries sorted in ascending order, with duplicates @@ -3900,6 +3974,26 @@ package Einfo is -- are fully analyzed and typed with the base type of the subtype. Note -- that all entries are static and have values within the subtype range. +-- Static_Real_Or_String_Predicate (Node25) +-- Defined in real types/subtypes with static predicates (with the two +-- flags Has_Predicates and Has_Static_Predicate set). Set if the type +-- or subtype has a static predicate. Points to the return expression +-- 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 +-- inherited, the expression is of the form: +-- +-- expression AND THEN xxxPredicate (typ2 (ent)) +-- +-- where typ2 is the type from which the predicate is inherited, ent is +-- the entity for the current predicate function, and xxxPredicate is the +-- inherited predicate (from typ2). Finally for a predicate that inherits +-- from another predicate but does not add a predicate of its own, the +-- expression may consist of the above xxxPredicate call on its own. + -- Status_Flag_Or_Transient_Decl (Node15) -- Defined in variables and constants. Applies to objects that require -- special treatment by the finalization machinery, such as extended @@ -4481,12 +4575,9 @@ package Einfo is -- or the use of an anonymous array subtype. E_String_Type, - -- A string type, i.e. an array type whose component type is a character - -- type, and for which string literals can thus be written. - E_String_Subtype, - -- A string subtype, created by an explicit subtype declaration for a - -- string type, or the use of an anonymous subtype of a string type, + -- These are obsolete and not used any more, they are retained to ease + -- transition in getting rid of these obsolete entries. E_String_Literal_Subtype, -- A special string subtype, used only to describe the type of a string @@ -4720,8 +4811,6 @@ package Einfo is subtype Aggregate_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype - -- E_String_Type - -- E_String_Subtype -- E_String_Literal_Subtype -- E_Class_Wide_Type -- E_Class_Wide_Subtype @@ -4731,8 +4820,6 @@ package Einfo is subtype Array_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype - -- E_String_Type - -- E_String_Subtype E_String_Literal_Subtype; subtype Assignable_Kind is Entity_Kind range @@ -4747,8 +4834,6 @@ package Einfo is subtype Composite_Kind is Entity_Kind range E_Array_Type .. -- E_Array_Subtype - -- E_String_Type - -- E_String_Subtype -- E_String_Literal_Subtype -- E_Class_Wide_Type -- E_Class_Wide_Subtype @@ -4973,11 +5058,6 @@ package Einfo is -- E_Floating_Point_Type E_Floating_Point_Subtype; - subtype String_Kind is Entity_Kind range - E_String_Type .. - -- E_String_Subtype - E_String_Literal_Subtype; - subtype Subprogram_Kind is Entity_Kind range E_Function .. -- E_Operator @@ -5016,8 +5096,6 @@ package Einfo is -- E_Anonymous_Access_Type -- E_Array_Type -- E_Array_Subtype - -- E_String_Type - -- E_String_Subtype -- E_String_Literal_Subtype -- E_Class_Wide_Subtype -- E_Class_Wide_Type @@ -5135,7 +5213,6 @@ package Einfo is -- Is_Trivial_Subprogram (Flag235) -- Is_Unchecked_Union (Flag117) -- Is_Visible_Formal (Flag206) - -- Is_VMS_Exception (Flag133) -- Kill_Elaboration_Checks (Flag32) -- Kill_Range_Checks (Flag33) -- Low_Bound_Tested (Flag205) @@ -5161,6 +5238,7 @@ package Einfo is -- Has_Foreign_Convention (synth) -- Is_Dynamic_Scope (synth) -- Is_Standard_Character_Type (synth) + -- Is_Standard_String_Type (synth) -- Underlying_Type (synth) -- all classification attributes (synth) @@ -5177,6 +5255,7 @@ package Einfo is -- Related_Expression (Node24) -- Current_Use_Clause (Node27) -- Subprograms_For_Type (Node29) + -- Derived_Type_Link (Node31) -- Linker_Section_Pragma (Node33) -- Depends_On_Private (Flag14) @@ -5191,11 +5270,13 @@ 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) -- 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) -- Has_Invariants (Flag232) -- Has_Non_Standard_Rep (Flag75) (base type only) -- Has_Object_Size_Clause (Flag172) @@ -5203,6 +5284,7 @@ package Einfo is -- Has_Pragma_Unreferenced_Objects (Flag212) -- Has_Predicates (Flag250) -- Has_Primitive_Operations (Flag120) (base type only) + -- Has_Protected (Flag271) (base type only) -- Has_Size_Clause (Flag29) -- Has_Specified_Layout (Flag100) (base type only) -- Has_Specified_Stream_Input (Flag190) @@ -5246,6 +5328,7 @@ package Einfo is -- Alignment_Clause (synth) -- Base_Type (synth) + -- Default_Init_Cond_Procedure (synth) -- Implementation_Base_Type (synth) -- Invariant_Procedure (synth) -- Is_Access_Protected_Subprogram_Type (synth) @@ -5338,6 +5421,8 @@ package Einfo is -- Has_Pragma_Pack (Flag121) (impl base type only) -- Is_Constrained (Flag12) -- Reverse_Storage_Order (Flag93) (base type only) + -- SSO_Set_High_By_Default (Flag273) (base type only) + -- SSO_Set_Low_By_Default (Flag272) (base type only) -- Next_Index (synth) -- Number_Dimensions (synth) -- (plus type attributes) @@ -5363,6 +5448,8 @@ package Einfo is -- First_Entity (Node17) -- Equivalent_Type (Node18) (always Empty for type) -- Last_Entity (Node20) + -- SSO_Set_High_By_Default (Flag273) (base type only) + -- SSO_Set_Low_By_Default (Flag272) (base type only) -- First_Component (synth) -- First_Component_Or_Discriminant (synth) -- (plus type attributes) @@ -5443,6 +5530,7 @@ package Einfo is -- Scalar_Range (Node20) -- Delta_Value (Ureal18) -- Small_Value (Ureal21) + -- Static_Real_Or_String_Predicate (Node25) -- Has_Machine_Radix_Clause (Flag83) -- Machine_Radix_10 (Flag84) -- Aft_Value (synth) @@ -5487,7 +5575,6 @@ package Einfo is -- Contract (Node34) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) - -- Is_AST_Entry (Flag132) (for entry only) -- Needs_No_Actuals (Flag22) -- Sec_Stack_Needed_For_Return (Flag167) -- Uses_Sec_Stack (Flag95) @@ -5517,12 +5604,14 @@ package Einfo is -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) -- Enum_Pos_To_Rep (Node23) (type only) - -- Static_Predicate (List25) + -- Static_Discrete_Predicate (List25) -- Has_Biased_Representation (Flag139) -- Has_Contiguous_Rep (Flag181) -- Has_Enumeration_Rep_Clause (Flag66) -- Has_Pragma_Ordered (Flag198) (base type only) -- Nonzero_Is_True (Flag162) (base type only) + -- No_Predicate_On_Actual (Flag275) + -- No_Dynamic_Predicate_On_Actual (Flag276) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5533,9 +5622,7 @@ package Einfo is -- Renamed_Entity (Node18) -- Register_Exception_Call (Node20) -- Interface_Name (Node21) - -- Exception_Code (Uint22) -- Discard_Names (Flag88) - -- Is_VMS_Exception (Flag133) -- Is_Raised (Flag224) -- E_Exception_Type @@ -5548,6 +5635,7 @@ package Einfo is -- Float_Rep (Uint10) (Float_Rep_Kind) -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) + -- Static_Real_Or_String_Predicate (Node25) -- Machine_Emax_Value (synth) -- Machine_Emin_Value (synth) -- Machine_Mantissa_Value (synth) @@ -5561,7 +5649,6 @@ package Einfo is -- Safe_Last_Value (synth) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) - -- Vax_Float (synth) -- (plus type attributes) -- E_Function @@ -5572,7 +5659,6 @@ package Einfo is -- Protected_Body_Subprogram (Node11) -- Next_Inlined_Subprogram (Node12) -- Elaboration_Entity (Node13) (not implicit /=) - -- First_Optional_Parameter (Node14) (non-generic case only) -- DT_Position (Uint15) -- DTC_Entity (Node16) -- First_Entity (Node17) @@ -5617,6 +5703,9 @@ package Einfo is -- Is_Discrim_SO_Function (Flag176) -- Is_Discriminant_Check_Function (Flag264) -- Is_Eliminated (Flag124) + -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) + -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) + -- Is_Inlined_Always (Flag1) (non-generic case only) -- Is_Instantiated (Flag126) (generic case only) -- Is_Intrinsic_Subprogram (Flag64) -- Is_Invariant_Procedure (Flag257) (non-generic case only) @@ -5633,6 +5722,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) -- Sec_Stack_Needed_For_Return (Flag167) -- SPARK_Pragma_Inherited (Flag265) -- Uses_Sec_Stack (Flag95) @@ -5697,7 +5787,6 @@ package Einfo is -- Has_Initial_Value (Flag219) -- Is_Controlling_Formal (Flag97) -- Is_Only_Out_Parameter (Flag226) - -- Is_Optional_Parameter (Flag134) -- Low_Bound_Tested (Flag205) -- Is_Return_Object (Flag209) -- Parameter_Mode (synth) @@ -5732,10 +5821,12 @@ package Einfo is -- Default_Aspect_Value (Node19) (base type only) -- Original_Array_Type (Node21) -- Scalar_Range (Node20) - -- Static_Predicate (List25) + -- Static_Discrete_Predicate (List25) -- Non_Binary_Modulus (Flag58) (base type only) -- Has_Biased_Representation (Flag139) -- Has_Shift_Operator (Flag267) (base type only) + -- No_Predicate_On_Actual (Flag275) + -- No_Dynamic_Predicate_On_Actual (Flag276) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) @@ -5768,6 +5859,7 @@ package Einfo is -- Delta_Value (Ureal18) -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) + -- Static_Real_Or_String_Predicate (Node25) -- Small_Value (Ureal21) -- Has_Small_Clause (Flag67) -- Aft_Value (synth) @@ -5867,7 +5959,6 @@ package Einfo is -- Protected_Body_Subprogram (Node11) -- Next_Inlined_Subprogram (Node12) -- Elaboration_Entity (Node13) - -- First_Optional_Parameter (Node14) (non-generic case only) -- DT_Position (Uint15) -- DTC_Entity (Node16) -- First_Entity (Node17) @@ -5906,7 +5997,11 @@ 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_Eliminated (Flag124) + -- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only) + -- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only) + -- Is_Inlined_Always (Flag1) (non-generic case only) -- Is_Instantiated (Flag126) (generic case only) -- Is_Interrupt_Handler (Flag89) -- Is_Intrinsic_Subprogram (Flag64) @@ -5991,6 +6086,8 @@ package Einfo is -- OK_To_Reorder_Components (Flag239) (base type only) -- Reverse_Bit_Order (Flag164) (base type only) -- Reverse_Storage_Order (Flag93) (base type only) + -- SSO_Set_High_By_Default (Flag273) (base type only) + -- SSO_Set_Low_By_Default (Flag272) (base type only) -- First_Component (synth) -- First_Component_Or_Discriminant (synth) -- (plus type attributes) @@ -6017,6 +6114,8 @@ package Einfo is -- OK_To_Reorder_Components (Flag239) (base type only) -- Reverse_Bit_Order (Flag164) (base type only) -- Reverse_Storage_Order (Flag93) (base type only) + -- SSO_Set_High_By_Default (Flag273) (base type only) + -- SSO_Set_Low_By_Default (Flag272) (base type only) -- First_Component (synth) -- First_Component_Or_Discriminant (synth) -- (plus type attributes) @@ -6028,22 +6127,15 @@ package Einfo is -- E_Signed_Integer_Subtype -- Default_Aspect_Value (Node19) (base type only) -- Scalar_Range (Node20) - -- Static_Predicate (List25) + -- Static_Discrete_Predicate (List25) -- Has_Biased_Representation (Flag139) -- Has_Shift_Operator (Flag267) (base type only) + -- No_Predicate_On_Actual (Flag275) + -- No_Dynamic_Predicate_On_Actual (Flag276) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) -- (plus type attributes) - -- E_String_Type - -- E_String_Subtype - -- First_Index (Node17) - -- Component_Type (Node20) (base type only) - -- Is_Constrained (Flag12) - -- Next_Index (synth) - -- Number_Dimensions (synth) - -- (plus type attributes) - -- E_String_Literal_Subtype -- String_Literal_Low_Bound (Node15) -- String_Literal_Length (Uint16) @@ -6184,8 +6276,7 @@ package Einfo is ----------------------------------- type Float_Rep_Kind is ( - IEEE_Binary, -- IEEE 754p conform binary format - VAX_Native, -- VAX D, F, G or H format + IEEE_Binary, -- IEEE 754p conforming binary format AAMP); -- AAMP format --------------- @@ -6436,6 +6527,7 @@ package Einfo is function Delta_Value (Id : E) return R; function Dependent_Instances (Id : E) return L; function Depends_On_Private (Id : E) return B; + function Derived_Type_Link (Id : E) return E; function Digits_Value (Id : E) return U; function Direct_Primitive_Operations (Id : E) return L; function Directly_Designated_Type (Id : E) return E; @@ -6466,7 +6558,6 @@ package Einfo is function Enumeration_Rep_Expr (Id : E) return N; function Equivalent_Type (Id : E) return E; function Esize (Id : E) return U; - function Exception_Code (Id : E) return U; function Extra_Accessibility (Id : E) return E; function Extra_Accessibility_Of_Result (Id : E) return E; function Extra_Constrained (Id : E) return E; @@ -6479,7 +6570,6 @@ package Einfo is function First_Exit_Statement (Id : E) return N; function First_Index (Id : E) return N; function First_Literal (Id : E) return E; - function First_Optional_Parameter (Id : E) return E; function First_Private_Entity (Id : E) return E; function First_Rep_Item (Id : E) return N; function Float_Rep (Id : E) return F; @@ -6505,6 +6595,7 @@ 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; @@ -6520,6 +6611,7 @@ 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_Initial_Value (Id : E) return B; function Has_Interrupt_Handler (Id : E) return B; function Has_Invariants (Id : E) return B; @@ -6551,6 +6643,7 @@ package Einfo is function Has_Primitive_Operations (Id : E) return B; function Has_Private_Ancestor (Id : E) return B; function Has_Private_Declaration (Id : E) return B; + function Has_Protected (Id : E) return B; function Has_Qualified_Name (Id : E) return B; function Has_RACW (Id : E) return B; function Has_Record_Rep_Clause (Id : E) return B; @@ -6587,7 +6680,6 @@ package Einfo is function Interface_Alias (Id : E) return E; function Interface_Name (Id : E) return N; function Interfaces (Id : E) return L; - function Is_AST_Entry (Id : E) return B; function Is_Abstract_Subprogram (Id : E) return B; function Is_Abstract_Type (Id : E) return B; function Is_Access_Constant (Id : E) return B; @@ -6610,6 +6702,7 @@ package Einfo is function Is_Constructor (Id : E) return B; function Is_Controlled (Id : E) return B; function Is_Controlling_Formal (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_Discrim_SO_Function (Id : E) return B; function Is_Discriminant_Check_Function (Id : E) return B; @@ -6623,12 +6716,14 @@ package Einfo is function Is_Frozen (Id : E) return B; function Is_Generic_Instance (Id : E) return B; function Is_Hidden (Id : E) return B; + function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B; function Is_Hidden_Open_Scope (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; function Is_Independent (Id : E) return B; function Is_Inlined (Id : E) return B; + function Is_Inlined_Always (Id : E) return B; function Is_Instantiated (Id : E) return B; function Is_Interface (Id : E) return B; function Is_Internal (Id : E) return B; @@ -6647,7 +6742,6 @@ package Einfo is function Is_Null_Init_Proc (Id : E) return B; function Is_Obsolescent (Id : E) return B; function Is_Only_Out_Parameter (Id : E) return B; - function Is_Optional_Parameter (Id : E) return B; function Is_Package_Body_Entity (Id : E) return B; function Is_Packed (Id : E) return B; function Is_Packed_Array_Impl_Type (Id : E) return B; @@ -6681,7 +6775,6 @@ package Einfo is function Is_Unchecked_Union (Id : E) return B; function Is_Underlying_Record_View (Id : E) return B; function Is_Unsigned_Type (Id : E) return B; - function Is_VMS_Exception (Id : E) return B; function Is_Valued_Procedure (Id : E) return B; function Is_Visible_Formal (Id : E) return B; function Is_Visible_Lib_Unit (Id : E) return B; @@ -6710,7 +6803,9 @@ package Einfo is function Needs_No_Actuals (Id : E) return B; function Never_Set_In_Source (Id : E) return B; function Next_Inlined_Subprogram (Id : E) return E; + function No_Dynamic_Predicate_On_Actual (Id : E) return B; function No_Pool_Assigned (Id : E) return B; + function No_Predicate_On_Actual (Id : E) return B; function No_Return (Id : E) return B; function No_Strict_Aliasing (Id : E) return B; function Non_Binary_Modulus (Id : E) return B; @@ -6761,6 +6856,7 @@ 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 Scalar_Range (Id : E) return N; @@ -6778,9 +6874,12 @@ package Einfo is function SPARK_Pragma (Id : E) return N; function SPARK_Pragma_Inherited (Id : E) return B; function Spec_Entity (Id : E) return E; + function SSO_Set_High_By_Default (Id : E) return B; + function SSO_Set_Low_By_Default (Id : E) return B; function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; - function Static_Predicate (Id : E) return S; + function Static_Discrete_Predicate (Id : E) return S; + function Static_Real_Or_String_Predicate (Id : E) return N; function Status_Flag_Or_Transient_Decl (Id : E) return E; function Storage_Size_Variable (Id : E) return E; function Stored_Constraint (Id : E) return L; @@ -6803,7 +6902,6 @@ package Einfo is function Used_As_Generic_Actual (Id : E) return B; function Uses_Lock_Free (Id : E) return B; function Uses_Sec_Stack (Id : E) return B; - function Vax_Float (Id : E) return B; function Warnings_Off (Id : E) return B; function Warnings_Off_Used (Id : E) return B; function Warnings_Off_Used_Unmodified (Id : E) return B; @@ -6844,6 +6942,7 @@ package Einfo is function Is_Formal (Id : E) return B; function Is_Formal_Object (Id : E) return B; function Is_Formal_Subprogram (Id : E) return B; + function Is_Generic_Actual_Subprogram (Id : E) return B; function Is_Generic_Actual_Type (Id : E) return B; function Is_Generic_Unit (Id : E) return B; function Is_Generic_Type (Id : E) return B; @@ -6909,6 +7008,7 @@ package Einfo is function Is_Protected_Interface (Id : E) return B; function Is_Protected_Record_Type (Id : E) return B; function Is_Standard_Character_Type (Id : E) return B; + function Is_Standard_String_Type (Id : E) return B; function Is_String_Type (Id : E) return B; function Is_Synchronized_Interface (Id : E) return B; function Is_Task_Interface (Id : E) return B; @@ -7066,6 +7166,7 @@ package Einfo is procedure Set_Delta_Value (Id : E; V : R); procedure Set_Dependent_Instances (Id : E; V : L); 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_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Directly_Designated_Type (Id : E; V : E); @@ -7095,7 +7196,6 @@ package Einfo is procedure Set_Enumeration_Rep_Expr (Id : E; V : N); procedure Set_Equivalent_Type (Id : E; V : E); procedure Set_Esize (Id : E; V : U); - procedure Set_Exception_Code (Id : E; V : U); procedure Set_Extra_Accessibility (Id : E; V : E); procedure Set_Extra_Accessibility_Of_Result (Id : E; V : E); procedure Set_Extra_Constrained (Id : E; V : E); @@ -7108,7 +7208,6 @@ package Einfo is procedure Set_First_Exit_Statement (Id : E; V : N); procedure Set_First_Index (Id : E; V : N); procedure Set_First_Literal (Id : E; V : E); - procedure Set_First_Optional_Parameter (Id : E; V : E); procedure Set_First_Private_Entity (Id : E; V : E); procedure Set_First_Rep_Item (Id : E; V : N); procedure Set_Float_Rep (Id : E; V : F); @@ -7134,6 +7233,7 @@ 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); @@ -7149,6 +7249,7 @@ 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_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); @@ -7179,6 +7280,7 @@ package Einfo is procedure Set_Has_Primitive_Operations (Id : E; V : B := True); procedure Set_Has_Private_Ancestor (Id : E; V : B := True); procedure Set_Has_Private_Declaration (Id : E; V : B := True); + procedure Set_Has_Protected (Id : E; V : B := True); procedure Set_Has_Qualified_Name (Id : E; V : B := True); procedure Set_Has_RACW (Id : E; V : B := True); procedure Set_Has_Record_Rep_Clause (Id : E; V : B := True); @@ -7215,7 +7317,6 @@ package Einfo is procedure Set_Interface_Alias (Id : E; V : E); procedure Set_Interface_Name (Id : E; V : N); procedure Set_Interfaces (Id : E; V : L); - procedure Set_Is_AST_Entry (Id : E; V : B := True); 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); @@ -7239,6 +7340,7 @@ package Einfo is procedure Set_Is_Constructor (Id : E; V : B := True); procedure Set_Is_Controlled (Id : E; V : B := True); procedure Set_Is_Controlling_Formal (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_Discrim_SO_Function (Id : E; V : B := True); procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True); @@ -7251,16 +7353,19 @@ package Einfo is procedure Set_Is_For_Access_Subtype (Id : E; V : B := True); procedure Set_Is_Formal_Subprogram (Id : E; V : B := True); procedure Set_Is_Frozen (Id : E; V : B := True); + procedure Set_Is_Generic_Actual_Subprogram (Id : E; V : B := True); procedure Set_Is_Generic_Actual_Type (Id : E; V : B := True); procedure Set_Is_Generic_Instance (Id : E; V : B := True); procedure Set_Is_Generic_Type (Id : E; V : B := True); procedure Set_Is_Hidden (Id : E; V : B := True); + 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_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); procedure Set_Is_Independent (Id : E; V : B := True); procedure Set_Is_Inlined (Id : E; V : B := True); + procedure Set_Is_Inlined_Always (Id : E; V : B := True); procedure Set_Is_Instantiated (Id : E; V : B := True); procedure Set_Is_Interface (Id : E; V : B := True); procedure Set_Is_Internal (Id : E; V : B := True); @@ -7280,7 +7385,6 @@ package Einfo is procedure Set_Is_Null_Init_Proc (Id : E; V : B := True); procedure Set_Is_Obsolescent (Id : E; V : B := True); procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True); - procedure Set_Is_Optional_Parameter (Id : E; V : B := True); procedure Set_Is_Package_Body_Entity (Id : E; V : B := True); procedure Set_Is_Packed (Id : E; V : B := True); procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True); @@ -7314,7 +7418,6 @@ package Einfo is procedure Set_Is_Unchecked_Union (Id : E; V : B := True); procedure Set_Is_Underlying_Record_View (Id : E; V : B := True); procedure Set_Is_Unsigned_Type (Id : E; V : B := True); - procedure Set_Is_VMS_Exception (Id : E; V : B := True); procedure Set_Is_Valued_Procedure (Id : E; V : B := True); procedure Set_Is_Visible_Formal (Id : E; V : B := True); procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True); @@ -7343,7 +7446,9 @@ package Einfo is procedure Set_Needs_No_Actuals (Id : E; V : B := True); procedure Set_Never_Set_In_Source (Id : E; V : B := True); procedure Set_Next_Inlined_Subprogram (Id : E; V : E); + procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True); procedure Set_No_Pool_Assigned (Id : E; V : B := True); + procedure Set_No_Predicate_On_Actual (Id : E; V : B := True); procedure Set_No_Return (Id : E; V : B := True); procedure Set_No_Strict_Aliasing (Id : E; V : B := True); procedure Set_Non_Binary_Modulus (Id : E; V : B := True); @@ -7394,6 +7499,7 @@ 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_Scalar_Range (Id : E; V : N); @@ -7411,9 +7517,12 @@ package Einfo is procedure Set_SPARK_Pragma (Id : E; V : N); procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True); procedure Set_Spec_Entity (Id : E; V : E); + procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True); + procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True); procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); - procedure Set_Static_Predicate (Id : E; V : S); + procedure Set_Static_Discrete_Predicate (Id : E; V : S); + procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N); procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E); procedure Set_Storage_Size_Variable (Id : E; V : E); procedure Set_Stored_Constraint (Id : E; V : L); @@ -7447,10 +7556,12 @@ package Einfo is -- Access to Subprograms in Subprograms_For_Type -- --------------------------------------------------- - function Invariant_Procedure (Id : E) return N; - function Predicate_Function (Id : E) return N; - function Predicate_Function_M (Id : E) return N; + 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; + 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); @@ -7808,6 +7919,7 @@ package Einfo is pragma Inline (Delta_Value); pragma Inline (Dependent_Instances); pragma Inline (Depends_On_Private); + pragma Inline (Derived_Type_Link); pragma Inline (Digits_Value); pragma Inline (Direct_Primitive_Operations); pragma Inline (Directly_Designated_Type); @@ -7838,7 +7950,6 @@ package Einfo is pragma Inline (Enumeration_Rep_Expr); pragma Inline (Equivalent_Type); pragma Inline (Esize); - pragma Inline (Exception_Code); pragma Inline (Extra_Accessibility); pragma Inline (Extra_Accessibility_Of_Result); pragma Inline (Extra_Constrained); @@ -7850,7 +7961,6 @@ package Einfo is pragma Inline (First_Exit_Statement); pragma Inline (First_Index); pragma Inline (First_Literal); - pragma Inline (First_Optional_Parameter); pragma Inline (First_Private_Entity); pragma Inline (First_Rep_Item); pragma Inline (Freeze_Node); @@ -7875,6 +7985,7 @@ 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); @@ -7890,6 +8001,7 @@ 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_Initial_Value); pragma Inline (Has_Invariants); pragma Inline (Has_Loop_Entry_Attributes); @@ -7920,6 +8032,7 @@ package Einfo is pragma Inline (Has_Primitive_Operations); pragma Inline (Has_Private_Ancestor); pragma Inline (Has_Private_Declaration); + pragma Inline (Has_Protected); pragma Inline (Has_Qualified_Name); pragma Inline (Has_RACW); pragma Inline (Has_Record_Rep_Clause); @@ -7955,7 +8068,6 @@ package Einfo is pragma Inline (Interface_Alias); pragma Inline (Interface_Name); pragma Inline (Interfaces); - pragma Inline (Is_AST_Entry); pragma Inline (Is_Abstract_Subprogram); pragma Inline (Is_Abstract_Type); pragma Inline (Is_Access_Constant); @@ -7990,6 +8102,7 @@ package Einfo is pragma Inline (Is_Controlled); pragma Inline (Is_Controlling_Formal); pragma Inline (Is_Decimal_Fixed_Point_Type); + pragma Inline (Is_Default_Init_Cond_Procedure); pragma Inline (Is_Descendent_Of_Address); pragma Inline (Is_Digits_Type); pragma Inline (Is_Discrete_Or_Fixed_Point_Type); @@ -8012,12 +8125,14 @@ package Einfo is pragma Inline (Is_Formal_Object); pragma Inline (Is_Formal_Subprogram); pragma Inline (Is_Frozen); + pragma Inline (Is_Generic_Actual_Subprogram); pragma Inline (Is_Generic_Actual_Type); pragma Inline (Is_Generic_Instance); pragma Inline (Is_Generic_Subprogram); pragma Inline (Is_Generic_Type); pragma Inline (Is_Generic_Unit); pragma Inline (Is_Hidden); + pragma Inline (Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Is_Hidden_Open_Scope); pragma Inline (Is_Immediately_Visible); pragma Inline (Is_Implementation_Defined); @@ -8026,6 +8141,7 @@ package Einfo is pragma Inline (Is_Incomplete_Type); pragma Inline (Is_Independent); pragma Inline (Is_Inlined); + pragma Inline (Is_Inlined_Always); pragma Inline (Is_Instantiated); pragma Inline (Is_Integer_Type); pragma Inline (Is_Interface); @@ -8050,7 +8166,6 @@ package Einfo is pragma Inline (Is_Object); pragma Inline (Is_Obsolescent); pragma Inline (Is_Only_Out_Parameter); - pragma Inline (Is_Optional_Parameter); pragma Inline (Is_Ordinary_Fixed_Point_Type); pragma Inline (Is_Overloadable); pragma Inline (Is_Package_Body_Entity); @@ -8095,7 +8210,6 @@ package Einfo is pragma Inline (Is_Unchecked_Union); pragma Inline (Is_Underlying_Record_View); pragma Inline (Is_Unsigned_Type); - pragma Inline (Is_VMS_Exception); pragma Inline (Is_Valued_Procedure); pragma Inline (Is_Visible_Formal); pragma Inline (Is_Visible_Lib_Unit); @@ -8125,7 +8239,9 @@ package Einfo is pragma Inline (Next_Index); pragma Inline (Next_Inlined_Subprogram); pragma Inline (Next_Literal); + pragma Inline (No_Dynamic_Predicate_On_Actual); pragma Inline (No_Pool_Assigned); + pragma Inline (No_Predicate_On_Actual); pragma Inline (No_Return); pragma Inline (No_Strict_Aliasing); pragma Inline (Non_Binary_Modulus); @@ -8177,6 +8293,7 @@ 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 (Scalar_Range); @@ -8194,9 +8311,12 @@ package Einfo is pragma Inline (SPARK_Pragma); pragma Inline (SPARK_Pragma_Inherited); pragma Inline (Spec_Entity); + pragma Inline (SSO_Set_High_By_Default); + pragma Inline (SSO_Set_Low_By_Default); pragma Inline (Static_Elaboration_Desired); pragma Inline (Static_Initialization); - pragma Inline (Static_Predicate); + pragma Inline (Static_Discrete_Predicate); + pragma Inline (Static_Real_Or_String_Predicate); pragma Inline (Status_Flag_Or_Transient_Decl); pragma Inline (Storage_Size_Variable); pragma Inline (Stored_Constraint); @@ -8285,6 +8405,7 @@ package Einfo is pragma Inline (Set_Delta_Value); pragma Inline (Set_Dependent_Instances); pragma Inline (Set_Depends_On_Private); + pragma Inline (Set_Derived_Type_Link); pragma Inline (Set_Digits_Value); pragma Inline (Set_Direct_Primitive_Operations); pragma Inline (Set_Directly_Designated_Type); @@ -8313,7 +8434,6 @@ package Einfo is pragma Inline (Set_Enumeration_Rep_Expr); pragma Inline (Set_Equivalent_Type); pragma Inline (Set_Esize); - pragma Inline (Set_Exception_Code); pragma Inline (Set_Extra_Accessibility); pragma Inline (Set_Extra_Accessibility_Of_Result); pragma Inline (Set_Extra_Constrained); @@ -8325,7 +8445,6 @@ package Einfo is pragma Inline (Set_First_Exit_Statement); pragma Inline (Set_First_Index); pragma Inline (Set_First_Literal); - pragma Inline (Set_First_Optional_Parameter); pragma Inline (Set_First_Private_Entity); pragma Inline (Set_First_Rep_Item); pragma Inline (Set_Freeze_Node); @@ -8350,6 +8469,7 @@ 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); @@ -8365,6 +8485,7 @@ 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_Initial_Value); pragma Inline (Set_Has_Invariants); pragma Inline (Set_Has_Loop_Entry_Attributes); @@ -8395,6 +8516,7 @@ package Einfo is pragma Inline (Set_Has_Primitive_Operations); pragma Inline (Set_Has_Private_Ancestor); pragma Inline (Set_Has_Private_Declaration); + pragma Inline (Set_Has_Protected); pragma Inline (Set_Has_Qualified_Name); pragma Inline (Set_Has_RACW); pragma Inline (Set_Has_Record_Rep_Clause); @@ -8430,7 +8552,6 @@ package Einfo is pragma Inline (Set_Interface_Alias); pragma Inline (Set_Interface_Name); pragma Inline (Set_Interfaces); - pragma Inline (Set_Is_AST_Entry); pragma Inline (Set_Is_Abstract_Subprogram); pragma Inline (Set_Is_Abstract_Type); pragma Inline (Set_Is_Access_Constant); @@ -8454,6 +8575,7 @@ package Einfo is pragma Inline (Set_Is_Constructor); pragma Inline (Set_Is_Controlled); pragma Inline (Set_Is_Controlling_Formal); + pragma Inline (Set_Is_Default_Init_Cond_Procedure); pragma Inline (Set_Is_Descendent_Of_Address); pragma Inline (Set_Is_Discrim_SO_Function); pragma Inline (Set_Is_Discriminant_Check_Function); @@ -8466,16 +8588,19 @@ package Einfo is pragma Inline (Set_Is_For_Access_Subtype); pragma Inline (Set_Is_Formal_Subprogram); pragma Inline (Set_Is_Frozen); + pragma Inline (Set_Is_Generic_Actual_Subprogram); pragma Inline (Set_Is_Generic_Actual_Type); pragma Inline (Set_Is_Generic_Instance); pragma Inline (Set_Is_Generic_Type); pragma Inline (Set_Is_Hidden); + pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm); pragma Inline (Set_Is_Hidden_Open_Scope); pragma Inline (Set_Is_Immediately_Visible); pragma Inline (Set_Is_Implementation_Defined); pragma Inline (Set_Is_Imported); pragma Inline (Set_Is_Independent); pragma Inline (Set_Is_Inlined); + pragma Inline (Set_Is_Inlined_Always); pragma Inline (Set_Is_Instantiated); pragma Inline (Set_Is_Interface); pragma Inline (Set_Is_Internal); @@ -8495,7 +8620,6 @@ package Einfo is pragma Inline (Set_Is_Null_Init_Proc); pragma Inline (Set_Is_Obsolescent); pragma Inline (Set_Is_Only_Out_Parameter); - pragma Inline (Set_Is_Optional_Parameter); pragma Inline (Set_Is_Package_Body_Entity); pragma Inline (Set_Is_Packed); pragma Inline (Set_Is_Packed_Array_Impl_Type); @@ -8529,7 +8653,6 @@ package Einfo is pragma Inline (Set_Is_Unchecked_Union); pragma Inline (Set_Is_Underlying_Record_View); pragma Inline (Set_Is_Unsigned_Type); - pragma Inline (Set_Is_VMS_Exception); pragma Inline (Set_Is_Valued_Procedure); pragma Inline (Set_Is_Visible_Formal); pragma Inline (Set_Is_Visible_Lib_Unit); @@ -8558,7 +8681,9 @@ package Einfo is pragma Inline (Set_Needs_No_Actuals); pragma Inline (Set_Never_Set_In_Source); pragma Inline (Set_Next_Inlined_Subprogram); + pragma Inline (Set_No_Dynamic_Predicate_On_Actual); pragma Inline (Set_No_Pool_Assigned); + pragma Inline (Set_No_Predicate_On_Actual); pragma Inline (Set_No_Return); pragma Inline (Set_No_Strict_Aliasing); pragma Inline (Set_Non_Binary_Modulus); @@ -8609,6 +8734,7 @@ 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_Scalar_Range); @@ -8626,9 +8752,12 @@ package Einfo is pragma Inline (Set_SPARK_Pragma); pragma Inline (Set_SPARK_Pragma_Inherited); pragma Inline (Set_Spec_Entity); + pragma Inline (Set_SSO_Set_High_By_Default); + pragma Inline (Set_SSO_Set_Low_By_Default); pragma Inline (Set_Static_Elaboration_Desired); pragma Inline (Set_Static_Initialization); - pragma Inline (Set_Static_Predicate); + pragma Inline (Set_Static_Discrete_Predicate); + pragma Inline (Set_Static_Real_Or_String_Predicate); pragma Inline (Set_Status_Flag_Or_Transient_Decl); pragma Inline (Set_Storage_Size_Variable); pragma Inline (Set_Stored_Constraint); diff --git a/main/gcc/ada/elists.adb b/main/gcc/ada/elists.adb index 7e62ce49f69..fbfb9e7b46b 100644 --- a/main/gcc/ada/elists.adb +++ b/main/gcc/ada/elists.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -138,6 +138,19 @@ package body Elists is end if; end Append_Elmt; + --------------------- + -- Append_New_Elmt -- + --------------------- + + procedure Append_New_Elmt (N : Node_Or_Entity_Id; To : in out Elist_Id) is + begin + if To = No_Elist then + To := New_Elmt_List; + end if; + + Append_Elmt (N, To); + end Append_New_Elmt; + ------------------------ -- Append_Unique_Elmt -- ------------------------ diff --git a/main/gcc/ada/elists.ads b/main/gcc/ada/elists.ads index f0331362ea3..3353b9cd17f 100644 --- a/main/gcc/ada/elists.ads +++ b/main/gcc/ada/elists.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +126,11 @@ package Elists is -- Appends N at the end of To, allocating a new element. N must be a -- non-empty node or entity Id, and To must be an Elist (not No_Elist). + procedure Append_New_Elmt (N : Node_Or_Entity_Id; To : in out Elist_Id); + pragma Inline (Append_New_Elmt); + -- Like Append_Elmt if Elist_Id is not No_List, but if Elist_Id is No_List, + -- then first assigns it an empty element list and then does the append. + procedure Append_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id); -- Like Append_Elmt, except that a check is made to see if To already -- contains N and if so the call has no effect. diff --git a/main/gcc/ada/err_vars.ads b/main/gcc/ada/err_vars.ads index 6009379c0a2..48df37e6362 100644 --- a/main/gcc/ada/err_vars.ads +++ b/main/gcc/ada/err_vars.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 @@ package Err_Vars is -- from invalid values in such cases. -- Note on error counts (Serious_Errors_Detected, Total_Errors_Detected, - -- Warnings_Detected). These counts might more logically appear in this - -- unit, but we place them in atree.ads, because of licensing issues. We - -- need to be able to access these counts from units that have the more - -- general licensing conditions. + -- Warnings_Detected, Info_Messages). These counts might more logically + -- appear in this unit, but we place them instead in atree.ads, because of + -- licensing issues. We need to be able to access these counts from units + -- that have the more general licensing conditions. ---------------------------------- -- Error Message Mode Variables -- @@ -93,7 +93,6 @@ package Err_Vars is -- are active (see errout.ads for details). If this switch is False, then -- these sequences are ignored (i.e. simply equivalent to a single ?). The -- -gnatw.d switch sets this flag True, -gnatw.D sets this flag False. - -- Note: always ignored on VMS, where we do not provide this capability. ---------------------------------------- -- Error Message Insertion Parameters -- diff --git a/main/gcc/ada/errout.adb b/main/gcc/ada/errout.adb index a2e9b45f1f3..55b02eeaab9 100644 --- a/main/gcc/ada/errout.adb +++ b/main/gcc/ada/errout.adb @@ -37,7 +37,6 @@ with Einfo; use Einfo; with Erroutc; use Erroutc; with Fname; use Fname; with Gnatvsn; use Gnatvsn; -with Hostparm; use Hostparm; with Lib; use Lib; with Opt; use Opt; with Nlists; use Nlists; @@ -156,11 +155,12 @@ package body Errout is -- variables Msg_Buffer are set on return Msglen. procedure Set_Posted (N : Node_Id); - -- Sets the Error_Posted flag on the given node, and all its parents - -- that are subexpressions and then on the parent non-subexpression - -- construct that contains the original expression (this reduces the - -- number of cascaded messages). Note that this call only has an effect - -- for a serious error. For a non-serious error, it has no effect. + -- Sets the Error_Posted flag on the given node, and all its parents that + -- are subexpressions and then on the parent non-subexpression construct + -- that contains the original expression. If that parent is a named + -- association, the flag is further propagated to its parent. This is done + -- in order to guard against cascaded errors. Note that this call has an + -- effect for a serious error only. procedure Set_Qualification (N : Nat; E : Entity_Id); -- Outputs up to N levels of qualification for the given entity. For @@ -189,14 +189,6 @@ package body Errout is -- should have 'Class appended to its name (see Add_Class procedure), and -- is otherwise unchanged. - procedure VMS_Convert; - -- This procedure has no effect if called when the host is not OpenVMS. If - -- the host is indeed OpenVMS, then the error message stored in Msg_Buffer - -- is scanned for appearances of switch names which need converting to - -- corresponding VMS qualifier names. See Gnames/Vnames table in Errout - -- spec for precise definition of the conversion that is performed by this - -- routine in OpenVMS mode. - function Warn_Insertion return String; -- This is called for warning messages only (so Warning_Msg_Char is set) -- and returns a corresponding string to use at the beginning of generated @@ -269,8 +261,12 @@ package body Errout is M.Deleted := True; Warnings_Detected := Warnings_Detected - 1; + if M.Info then + Info_Messages := Info_Messages - 1; + end if; + if M.Warn_Err then - Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1; end if; end if; @@ -1140,6 +1136,10 @@ package body Errout is 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; + end if; + else Total_Errors_Detected := Total_Errors_Detected + 1; @@ -1348,8 +1348,12 @@ package body Errout is Errors.Table (E).Deleted := True; Warnings_Detected := Warnings_Detected - 1; + if Errors.Table (E).Info then + Info_Messages := Info_Messages - 1; + end if; + if Errors.Table (E).Warn_Err then - Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; + Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1; end if; end if; end Delete_Warning; @@ -1574,6 +1578,7 @@ package body Errout is 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; @@ -1664,8 +1669,7 @@ package body Errout is begin -- Extra blank line if error messages or source listing were output - if Total_Errors_Detected + Warnings_Detected > 0 - or else Full_List + if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List then Write_Eol; end if; @@ -1674,13 +1678,8 @@ package body Errout is -- This normally goes to Standard_Output. The exception is when brief -- mode is not set, verbose mode (or full list mode) is set, and -- there are errors. In this case we send the message to standard - -- error to make sure that *something* appears on standard error in - -- an error situation. - - -- Formerly, only the "# errors" suffix was sent to stderr, whereas - -- "# lines:" appeared on stdout. This caused problems on VMS when - -- the stdout buffer was flushed, giving an extra line feed after - -- the prefix. + -- error to make sure that *something* appears on standard error + -- in an error situation. if Total_Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output @@ -1715,12 +1714,12 @@ package body Errout is Write_Str (" errors"); end if; - if Warnings_Detected /= 0 then + if Warnings_Detected - Info_Messages /= 0 then Write_Str (", "); Write_Int (Warnings_Detected); Write_Str (" warning"); - if Warnings_Detected /= 1 then + if Warnings_Detected - Info_Messages /= 1 then Write_Char ('s'); end if; @@ -1740,6 +1739,16 @@ package body Errout is end if; end if; + if Info_Messages /= 0 then + Write_Str (", "); + Write_Int (Info_Messages); + Write_Str (" info message"); + + if Info_Messages > 1 then + Write_Char ('s'); + end if; + end if; + Write_Eol; Set_Standard_Output; end Write_Error_Summary; @@ -1760,9 +1769,11 @@ package body Errout is Write_Name (Full_File_Name (Sfile)); if not Debug_Flag_7 then - Write_Str (" (source file time stamp: "); + Write_Eol; + Write_Str ("Source file time stamp: "); Write_Time_Stamp (Sfile); - Write_Char (')'); + Write_Eol; + Write_Str ("Compiled at: " & Compilation_Time); end if; Write_Eol; @@ -1944,8 +1955,8 @@ package body Errout is Err_Flag := E /= No_Error_Msg - and then Errors.Table (E).Line = N - and then Errors.Table (E).Sfile = Sfile; + and then Errors.Table (E).Line = N + and then Errors.Table (E).Sfile = Sfile; Output_Source_Line (N, Sfile, Err_Flag); @@ -2038,8 +2049,9 @@ package body Errout is Write_Max_Errors; if Warning_Mode = Treat_As_Error then - Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; - Warnings_Detected := 0; + Total_Errors_Detected := + Total_Errors_Detected + Warnings_Detected - Info_Messages; + Warnings_Detected := Info_Messages; end if; end Output_Messages; @@ -2211,6 +2223,11 @@ package body Errout is and then not Errors.Table (E).Uncond then Warnings_Detected := Warnings_Detected - 1; + + if Errors.Table (E).Info then + Info_Messages := Info_Messages - 1; + end if; + return True; -- No removal required @@ -2328,9 +2345,7 @@ package body Errout is -- Loop through file names to find matching one. This is a bit slow, but -- we only do it in error situations so it is not so terrible. Note that -- if the loop does not exit, then the desired case will be left set to - -- Mixed_Case, this can happen if the name was not in canonical form, - -- and gets canonicalized on VMS. Possibly we could fix this by - -- unconditionally canonicalizing these names ??? + -- Mixed_Case, this can happen if the name was not in canonical form. for J in 1 .. Last_Source_File loop Get_Name_String (Full_Debug_Name (J)); @@ -2977,8 +2992,6 @@ package body Errout is Set_Msg_Char (C); end case; end loop; - - VMS_Convert; end Set_Msg_Text; ---------------- @@ -3007,6 +3020,15 @@ package body Errout is exit when Nkind (P) not in N_Subexpr; end loop; + if Nkind_In (P, N_Pragma_Argument_Association, + N_Component_Association, + N_Discriminant_Association, + N_Generic_Association, + N_Parameter_Association) + then + Set_Error_Posted (Parent (P)); + end if; + -- A special check, if we just posted an error on an attribute -- definition clause, then also set the entity involved as posted. -- For example, this stops complaining about the alignment after @@ -3280,55 +3302,6 @@ package body Errout is end if; end Unwind_Internal_Type; - ----------------- - -- VMS_Convert -- - ----------------- - - procedure VMS_Convert is - P : Natural; - L : Natural; - N : Natural; - - begin - if not OpenVMS then - return; - end if; - - P := Msg_Buffer'First; - loop - if P >= Msglen then - return; - end if; - - if Msg_Buffer (P) = '-' then - for G in Gnames'Range loop - L := Gnames (G)'Length; - - -- See if we have "-ggg switch", where ggg is Gnames entry - - if P + L + 7 <= Msglen - and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all - and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch" - then - -- Replace by "/vvv qualifier", where vvv is Vnames entry - - N := Vnames (G)'Length; - Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) := - Msg_Buffer (P + L + 8 .. Msglen); - Msg_Buffer (P) := '/'; - Msg_Buffer (P + 1 .. P + N) := Vnames (G).all; - Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier"; - P := P + N + 10; - Msglen := Msglen + N - L + 3; - exit; - end if; - end loop; - end if; - - P := P + 1; - end loop; - end VMS_Convert; - -------------------- -- Warn_Insertion -- -------------------- diff --git a/main/gcc/ada/errout.ads b/main/gcc/ada/errout.ads index 303c21494eb..eaed2aa4cba 100644 --- a/main/gcc/ada/errout.ads +++ b/main/gcc/ada/errout.ads @@ -413,68 +413,6 @@ package Errout is -- are continuations that are not printed using the -gnatj switch they -- will also have this prefix. - ---------------------------------------- - -- Specialization of Messages for VMS -- - ---------------------------------------- - - -- Some messages mention gcc-style switch names. When using an OpenVMS - -- host, such switch names must be converted to their corresponding VMS - -- qualifer. The following table controls this translation. In each case - -- the original message must contain the string "-xxx switch", where xxx - -- is the Gname? entry from below, and this string will be replaced by - -- "/yyy qualifier", where yyy is the corresponding Vname? entry. - - Gname1 : aliased constant String := "fno-strict-aliasing"; - Vname1 : aliased constant String := "OPTIMIZE=NO_STRICT_ALIASING"; - - Gname2 : aliased constant String := "gnatX"; - Vname2 : aliased constant String := "EXTENSIONS_ALLOWED"; - - Gname3 : aliased constant String := "gnatW"; - Vname3 : aliased constant String := "WIDE_CHARACTER_ENCODING"; - - Gname4 : aliased constant String := "gnatf"; - Vname4 : aliased constant String := "REPORT_ERRORS=FULL"; - - Gname5 : aliased constant String := "gnat05"; - Vname5 : aliased constant String := "05"; - - Gname6 : aliased constant String := "gnat2005"; - Vname6 : aliased constant String := "2005"; - - Gname7 : aliased constant String := "gnat12"; - Vname7 : aliased constant String := "12"; - - Gname8 : aliased constant String := "gnat2012"; - Vname8 : aliased constant String := "2012"; - - Gname9 : aliased constant String := "gnateinn"; - Vname9 : aliased constant String := "MAX_INSTANTIATIONS=nn"; - - type Cstring_Ptr is access constant String; - - Gnames : array (Nat range <>) of Cstring_Ptr := - (Gname1'Access, - Gname2'Access, - Gname3'Access, - Gname4'Access, - Gname5'Access, - Gname6'Access, - Gname7'Access, - Gname8'Access, - Gname9'Access); - - Vnames : array (Nat range <>) of Cstring_Ptr := - (Vname1'Access, - Vname2'Access, - Vname3'Access, - Vname4'Access, - Vname5'Access, - Vname6'Access, - Vname7'Access, - Vname8'Access, - Vname9'Access); - ----------------------------------------------------- -- Global Values Used for Error Message Insertions -- ----------------------------------------------------- @@ -836,7 +774,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 - -- style messages (identified by the fact that they start with "(style)" + -- 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. diff --git a/main/gcc/ada/erroutc.adb b/main/gcc/ada/erroutc.adb index 66ab8f18452..11eef8a9593 100644 --- a/main/gcc/ada/erroutc.adb +++ b/main/gcc/ada/erroutc.adb @@ -42,6 +42,7 @@ with Snames; use Snames; with Stringt; use Stringt; with Targparm; use Targparm; with Uintp; use Uintp; +with Widechar; use Widechar; package body Erroutc is @@ -140,10 +141,9 @@ package body Erroutc is if Errors.Table (D).Warn or else Errors.Table (D).Style then Warnings_Detected := Warnings_Detected - 1; - if Errors.Table (D).Warn_Err then - Warnings_Treated_As_Errors := - Warnings_Treated_As_Errors + 1; - end if; + -- Note: we do not need to decrement Warnings_Treated_As_Errors + -- because this only gets incremented if we actually output the + -- message, which we won't do if we are deleting it here! else Total_Errors_Detected := Total_Errors_Detected - 1; @@ -232,7 +232,7 @@ package body Erroutc is function Compilation_Errors return Boolean is begin return Total_Errors_Detected /= 0 - or else (Warnings_Detected /= 0 + or else (Warnings_Detected - Info_Messages /= 0 and then Warning_Mode = Treat_As_Error) or else Warnings_Treated_As_Errors /= 0; end Compilation_Errors; @@ -445,32 +445,75 @@ package body Erroutc is and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile loop - -- Loop to output blanks till current flag position + declare + Src : Source_Buffer_Ptr + renames Source_Text (Errors.Table (T).Sfile); - while P < Errors.Table (T).Sptr loop - if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then - Write_Char (ASCII.HT); - else - Write_Char (' '); - end if; + begin + -- Loop to output blanks till current flag position - P := P + 1; - end loop; + while P < Errors.Table (T).Sptr loop - -- Output flag (unless already output, this happens if more - -- than one error message occurs at the same flag position). + -- Horizontal tab case, just echo the tab - if P = Errors.Table (T).Sptr then - if (Flag_Num = 1 and then not Mult_Flags) - or else Flag_Num > 9 - then - Write_Char ('|'); - else - Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); - end if; + if Src (P) = ASCII.HT then + Write_Char (ASCII.HT); + P := P + 1; - P := P + 1; - end if; + -- Deal with wide character case, but don't include brackets + -- notation in this circuit, since we know that this will + -- display unencoded (no one encodes brackets notation). + + elsif Src (P) /= '[' + and then Is_Start_Of_Wide_Char (Src, P) + then + Skip_Wide (Src, P); + Write_Char (' '); + + -- Normal non-wide character case (or bracket) + + else + P := P + 1; + Write_Char (' '); + end if; + end loop; + + -- Output flag (unless already output, this happens if more + -- than one error message occurs at the same flag position). + + if P = Errors.Table (T).Sptr then + if (Flag_Num = 1 and then not Mult_Flags) + or else Flag_Num > 9 + then + Write_Char ('|'); + else + Write_Char + (Character'Val (Character'Pos ('0') + Flag_Num)); + end if; + + -- Skip past the corresponding source text character + + -- Horizontal tab case, we output a flag at the tab position + -- so now we output a tab to match up with the text. + + if Src (P) = ASCII.HT then + Write_Char (ASCII.HT); + P := P + 1; + + -- Skip wide character other than left bracket + + elsif Src (P) /= '[' + and then Is_Start_Of_Wide_Char (Src, P) + then + Skip_Wide (Src, P); + + -- Skip normal non-wide character case (or bracket) + + else + P := P + 1; + end if; + end if; + end; Set_Next_Non_Deleted_Msg (T); Flag_Num := Flag_Num + 1; diff --git a/main/gcc/ada/errutil.adb b/main/gcc/ada/errutil.adb index f15eec9a7b1..7eb85a4193a 100644 --- a/main/gcc/ada/errutil.adb +++ b/main/gcc/ada/errutil.adb @@ -201,24 +201,27 @@ package body Errutil is -- Otherwise build error message object for new message - Errors.Increment_Last; - Cur_Msg := Errors.Last; - Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); - Errors.Table (Cur_Msg).Next := No_Error_Msg; - Errors.Table (Cur_Msg).Sptr := Sptr; - Errors.Table (Cur_Msg).Optr := Optr; - Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr); - Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr); - Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr); - Errors.Table (Cur_Msg).Style := Is_Style_Msg; - Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; - Errors.Table (Cur_Msg).Info := Is_Info_Msg; - Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; - Errors.Table (Cur_Msg).Serious := Is_Serious_Error; - Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; - Errors.Table (Cur_Msg).Msg_Cont := Continuation; - Errors.Table (Cur_Msg).Deleted := False; - + Errors.Append + (New_Val => + (Text => new String'(Msg_Buffer (1 .. Msglen)), + Next => No_Error_Msg, + Prev => No_Error_Msg, + Sfile => Get_Source_File_Index (Sptr), + Sptr => Sptr, + Optr => Optr, + Line => Get_Physical_Line_Number (Sptr), + Col => Get_Column_Number (Sptr), + Warn => Is_Warning_Msg, + Info => Is_Info_Msg, + Warn_Err => Warning_Mode = Treat_As_Error, + Warn_Chr => Warning_Msg_Char, + Style => Is_Style_Msg, + Serious => Is_Serious_Error, + Uncond => Is_Unconditional_Msg, + Msg_Cont => Continuation, + Deleted => False)); + + Cur_Msg := Errors.Last; Prev_Msg := No_Error_Msg; Next_Msg := First_Error_Msg; @@ -306,6 +309,10 @@ package body Errutil is then Warnings_Detected := Warnings_Detected + 1; + if Errors.Table (Cur_Msg).Info then + Info_Messages := Info_Messages + 1; + end if; + else Total_Errors_Detected := Total_Errors_Detected + 1; @@ -499,10 +506,10 @@ package body Errutil is -- error to make sure that *something* appears on standard error in -- an error situation. - -- Formerly, only the "# errors" suffix was sent to stderr, whereas - -- "# lines:" appeared on stdout. This caused problems on VMS when - -- the stdout buffer was flushed, giving an extra line feed after - -- the prefix. + -- Historical note: Formerly, only the "# errors" suffix was sent + -- to stderr, whereas "# lines:" appeared on stdout. This caused + -- some problems on now-obsolete ports, but there seems to be no + -- reason to revert this page since it would be incompatible. if Total_Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output @@ -533,19 +540,19 @@ package body Errutil is Write_Str (" errors"); end if; - if Warnings_Detected /= 0 then + if Warnings_Detected - Info_Messages /= 0 then Write_Str (", "); - Write_Int (Warnings_Detected); + Write_Int (Warnings_Detected - Info_Messages); Write_Str (" warning"); - if Warnings_Detected /= 1 then + if Warnings_Detected - Info_Messages /= 1 then Write_Char ('s'); end if; if Warning_Mode = Treat_As_Error then Write_Str (" (treated as error"); - if Warnings_Detected /= 1 then + if Warnings_Detected - Info_Messages /= 1 then Write_Char ('s'); end if; @@ -572,8 +579,9 @@ package body Errutil is end if; if Warning_Mode = Treat_As_Error then - Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; - Warnings_Detected := 0; + Total_Errors_Detected := + Total_Errors_Detected + Warnings_Detected - Info_Messages; + Warnings_Detected := Info_Messages; end if; -- Prevent displaying the same messages again in the future @@ -593,6 +601,7 @@ package body Errutil is Serious_Errors_Detected := 0; Total_Errors_Detected := 0; Warnings_Detected := 0; + Info_Messages := 0; Cur_Msg := No_Error_Msg; -- Initialize warnings table, if all warnings are suppressed, supply @@ -772,6 +781,9 @@ package body Errutil is P := P - 1; Set_Msg_Insertion_Reserved_Word (Text, P); + elsif C = '~' then + Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen)); + -- Normal character with no special treatment else diff --git a/main/gcc/ada/exp_aggr.adb b/main/gcc/ada/exp_aggr.adb index de784b2daf9..60838de3674 100644 --- a/main/gcc/ada/exp_aggr.adb +++ b/main/gcc/ada/exp_aggr.adb @@ -289,11 +289,6 @@ package body Exp_Aggr is -- If this transformation is not possible, N is unchanged and False is -- returned. - function Safe_Slice_Assignment (N : Node_Id) return Boolean; - -- If a slice assignment has an aggregate with a single others_choice, - -- the assignment can be done in place even if bounds are not static, - -- by converting it into a loop over the discrete range of the slice. - function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean; -- If the type of the aggregate is a two-dimensional bit_packed array -- it may be transformed into an array of bytes with constant values, @@ -404,8 +399,8 @@ package body Exp_Aggr is elsif Restriction_Active (No_Elaboration_Code) or else Restriction_Active (No_Implicit_Loops) or else Is_Two_Dim_Packed_Array (Typ) - or else ((Ekind (Current_Scope) = E_Package - and then Static_Elaboration_Desired (Current_Scope))) + or else (Ekind (Current_Scope) = E_Package + and then Static_Elaboration_Desired (Current_Scope)) then Max_Aggr_Size := 2 ** 24; @@ -443,9 +438,7 @@ package body Exp_Aggr is -- is an object declaration with non-static bounds it will trip gcc; -- such an aggregate must be expanded into a single assignment. - if Hiv = Lov - and then Nkind (Parent (N)) = N_Object_Declaration - then + if Hiv = Lov and then Nkind (Parent (N)) = N_Object_Declaration then declare Index_Type : constant Entity_Id := Etype @@ -454,8 +447,8 @@ package body Exp_Aggr is begin if not Compile_Time_Known_Value (Type_Low_Bound (Index_Type)) - or else not Compile_Time_Known_Value - (Type_High_Bound (Index_Type)) + or else not Compile_Time_Known_Value + (Type_High_Bound (Index_Type)) then if Present (Component_Associations (N)) then Indx := @@ -603,7 +596,7 @@ package body Exp_Aggr is -- Recursion to following indexes for multiple dimension case if Present (Next_Index (Index)) - and then not Component_Check (Expr, Next_Index (Index)) + and then not Component_Check (Expr, Next_Index (Index)) then return False; end if; @@ -653,11 +646,11 @@ package body Exp_Aggr is end if; -- Checks 5 (if the component type is tagged, then we may need to do - -- tag adjustments. Perhaps this should be refined to check for any - -- component associations that actually need tag adjustment, similar - -- to the test in Component_Not_OK_For_Backend for record aggregates - -- with tagged components, but not clear whether it's worthwhile ???; - -- in the case of the JVM, object tags are handled implicitly) + -- tag adjustments. Perhaps this should be refined to check for any + -- component associations that actually need tag adjustment, similar + -- to the test in Component_Not_OK_For_Backend for record aggregates + -- with tagged components, but not clear whether it's worthwhile ???; + -- in the case of the JVM, object tags are handled implicitly) if Is_Tagged_Type (Component_Type (Typ)) and then Tagged_Type_Expansion @@ -934,7 +927,8 @@ package body Exp_Aggr is end case; if Local_Compile_Time_Known_Value (Low) - and then Local_Compile_Time_Known_Value (High) + and then + Local_Compile_Time_Known_Value (High) then Is_Empty := UI_Gt (Local_Expr_Value (Low), Local_Expr_Value (High)); @@ -956,7 +950,8 @@ package body Exp_Aggr is return True; elsif Local_Compile_Time_Known_Value (L) - and then Local_Compile_Time_Known_Value (H) + and then + Local_Compile_Time_Known_Value (H) then return UI_Eq (Local_Expr_Value (L), Local_Expr_Value (H)); end if; @@ -1053,9 +1048,7 @@ package body Exp_Aggr is Expr_Q := Expr; end if; - if Present (Etype (N)) - and then Etype (N) /= Any_Composite - then + if Present (Etype (N)) and then Etype (N) /= Any_Composite then Comp_Type := Component_Type (Etype (N)); pragma Assert (Comp_Type = Ctype); -- AI-287 @@ -1066,13 +1059,13 @@ package body Exp_Aggr is -- the formal parameter Ctype. -- ??? Some assert pragmas have been added to check if this new - -- formal can be used to replace this code in all cases. + -- formal can be used to replace this code in all cases. if Present (Expr) then - -- This is a multidimensional array. Recover the component - -- type from the outermost aggregate, because subaggregates - -- do not have an assigned type. + -- This is a multidimensional array. Recover the component type + -- from the outermost aggregate, because subaggregates do not + -- have an assigned type. declare P : Node_Id; @@ -1170,9 +1163,9 @@ package body Exp_Aggr is if Needs_Finalization (Ctype) then Append_To (L, - Make_Init_Call ( - Obj_Ref => New_Copy_Tree (Indexed_Comp), - Typ => Ctype)); + Make_Init_Call + (Obj_Ref => New_Copy_Tree (Indexed_Comp), + Typ => Ctype)); end if; else @@ -1265,13 +1258,13 @@ package body Exp_Aggr is 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) + 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)); + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Indexed_Comp), + Typ => Comp_Type)); end if; end if; @@ -1413,11 +1406,12 @@ package body Exp_Aggr is -- Construct the final loop - Append_To (S, Make_Implicit_Loop_Statement - (Node => N, - Identifier => Empty, - Iteration_Scheme => L_Iteration_Scheme, - Statements => L_Body)); + Append_To (S, + Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => L_Iteration_Scheme, + Statements => L_Body)); -- A small optimization: if the aggregate is initialized with a box -- and the component type has no initialization procedure, remove the @@ -1520,11 +1514,12 @@ package body Exp_Aggr is -- Construct the final loop - Append_To (S, Make_Implicit_Loop_Statement - (Node => N, - Identifier => Empty, - Iteration_Scheme => W_Iteration_Scheme, - Statements => W_Body)); + Append_To (S, + Make_Implicit_Loop_Statement + (Node => N, + Identifier => Empty, + Iteration_Scheme => W_Iteration_Scheme, + Statements => W_Body)); return S; end Gen_While; @@ -1611,7 +1606,7 @@ package body Exp_Aggr is then Append_To (New_Code, Make_Assignment_Statement (Loc, - Name => New_Copy_Tree (Into), + Name => New_Copy_Tree (Into), Expression => Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, Uint_0)))); @@ -1621,9 +1616,7 @@ package body Exp_Aggr is -- entity in the current scope, because it will be needed if build- -- in-place functions are called in the expanded code. - if Nkind (Parent (N)) = N_Object_Declaration - and then Has_Task (Typ) - then + if Nkind (Parent (N)) = N_Object_Declaration and then Has_Task (Typ) then Build_Master_Entity (Defining_Identifier (Parent (N))); end if; @@ -1852,7 +1845,9 @@ package body Exp_Aggr is 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 - -- initialized. The assignments are appended to List. + -- initialized. The assignments are appended to List. The same is done + -- 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 @@ -2119,14 +2114,41 @@ package body Exp_Aggr is Discr_Val : Elmt_Id; begin + -- The constraints on the hidden discriminants, if present, are kept + -- in the Stored_Constraint list of the type itself, or in that of + -- the base type. + Btype := Base_Type (Typ); while Is_Derived_Type (Btype) - and then Present (Stored_Constraint (Btype)) + and then (Present (Stored_Constraint (Btype)) + or else + Present (Stored_Constraint (Typ))) loop Parent_Type := Etype (Btype); + if not Has_Discriminants (Parent_Type) then + return; + end if; + Disc := First_Discriminant (Parent_Type); - Discr_Val := First_Elmt (Stored_Constraint (Base_Type (Typ))); + + -- We know that one of the stored-constraint lists is present + + if Present (Stored_Constraint (Btype)) then + Discr_Val := First_Elmt (Stored_Constraint (Btype)); + + -- For private extension, stored constraint may be on full view + + elsif Is_Private_Type (Btype) + and then Present (Full_View (Btype)) + and then Present (Stored_Constraint (Full_View (Btype))) + then + Discr_Val := First_Elmt (Stored_Constraint (Full_View (Btype))); + + else + Discr_Val := First_Elmt (Stored_Constraint (Typ)); + end if; + while Present (Discr_Val) loop -- Only those discriminants of the parent that are not @@ -2184,20 +2206,18 @@ package body Exp_Aggr is 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. + -- 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 + 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 => + Name => New_Occurrence_Of (Find_Prim_Op (Init_Typ, Name_Initialize), Loc), Parameter_Associations => New_List (New_Copy_Tree (Ref)))); @@ -2223,14 +2243,15 @@ package body Exp_Aggr is 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)) + 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; @@ -2421,13 +2442,14 @@ package body Exp_Aggr is -- in the limited case, the ancestor part must be either a -- function call (possibly qualified, or wrapped in an unchecked -- conversion) or aggregate (definitely qualified). + -- The ancestor part can also be a function call (that may be -- transformed into an explicit dereference) or a qualification -- of one such. elsif Is_Limited_Type (Etype (Ancestor)) and then Nkind_In (Unqualify (Ancestor), N_Aggregate, - N_Extension_Aggregate) + N_Extension_Aggregate) then Ancestor_Is_Expression := True; @@ -2520,9 +2542,9 @@ package body Exp_Aggr is and then not Is_Limited_Type (Etype (Ancestor)) then Append_To (Assign, - Make_Adjust_Call ( - Obj_Ref => New_Copy_Tree (Ref), - Typ => Etype (Ancestor))); + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Ref), + Typ => Etype (Ancestor))); end if; Append_To (L, @@ -2596,9 +2618,7 @@ package body Exp_Aggr is -- constructor to ensure the proper initialization of the _Tag -- component. - if Is_CPP_Class (Root_Type (Typ)) - and then CPP_Num_Prims (Typ) > 0 - then + if Is_CPP_Class (Root_Type (Typ)) and then CPP_Num_Prims (Typ) > 0 then Invoke_Constructor : declare CPP_Parent : constant Entity_Id := Enclosing_CPP_Parent (Typ); @@ -2640,9 +2660,8 @@ package body Exp_Aggr is if Nkind (N) = N_Aggregate then Append_To (L, Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of - (Base_Init_Proc (CPP_Parent), Loc), + Name => + New_Occurrence_Of (Base_Init_Proc (CPP_Parent), Loc), Parameter_Associations => New_List ( Unchecked_Convert_To (CPP_Parent, New_Copy_Tree (Lhs))))); @@ -2667,10 +2686,10 @@ package body Exp_Aggr is if Is_CPP_Constructor_Call (Expression (Comp)) then Append_List_To (L, Build_Initialization_Call (Loc, - Id_Ref => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of (Selector, Loc)), + Id_Ref => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Selector, Loc)), Typ => Etype (Selector), Enclos_Type => Typ, With_Default_Init => True, @@ -2847,6 +2866,38 @@ package body Exp_Aggr is else if Has_Discriminants (Typ) then Replace_Discriminants (Expr_Q); + + -- If the component is an array type that depends on + -- discriminants, and the expression is a single Others + -- clause, create an explicit subtype for it because the + -- backend has troubles recovering the actual bounds. + + if Nkind (Expr_Q) = N_Aggregate + and then Is_Array_Type (Comp_Type) + and then Present (Component_Associations (Expr_Q)) + then + declare + Assoc : constant Node_Id := + First (Component_Associations (Expr_Q)); + Decl : Node_Id; + + begin + if Nkind (First (Choices (Assoc))) = N_Others_Choice + then + Decl := + Build_Actual_Subtype_Of_Component + (Comp_Type, Comp_Expr); + + -- If the component type does not in fact depend on + -- discriminants, the subtype declaration is empty. + + if Present (Decl) then + Append_To (L, Decl); + Set_Etype (Comp_Expr, Defining_Entity (Decl)); + end if; + end if; + end; + end if; end if; Instr := @@ -2891,13 +2942,13 @@ package body Exp_Aggr is 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)); + Make_Adjust_Call + (Obj_Ref => New_Copy_Tree (Comp_Expr), + Typ => Comp_Type)); end if; end if; - -- ??? + -- comment would be good here ??? elsif Ekind (Selector) = E_Discriminant and then Nkind (N) /= N_Extension_Aggregate @@ -2935,9 +2986,9 @@ package body Exp_Aggr is Make_Raise_Constraint_Error (Loc, Condition => Make_Op_Ne (Loc, - Left_Opnd => New_Copy_Tree (Node (D_Val)), + Left_Opnd => New_Copy_Tree (Node (D_Val)), Right_Opnd => Expression (Comp)), - Reason => CE_Discriminant_Check_Failed)); + Reason => CE_Discriminant_Check_Failed)); else -- Find self-reference in previous discriminant assignment, @@ -2952,7 +3003,7 @@ package body Exp_Aggr is if Nkind (Ass) = N_Assignment_Statement and then Nkind (Name (Ass)) = N_Selected_Component and then Chars (Selector_Name (Name (Ass))) = - Chars (Disc) + Chars (Disc) then Set_Expression (Ass, New_Copy_Tree (Expression (Comp))); @@ -2968,10 +3019,10 @@ package body Exp_Aggr is Next (Comp); end loop; - -- If the type is tagged, the tag needs to be initialized (unless - -- compiling for the Java VM where tags are implicit). It is done - -- late in the initialization process because in some cases, we call - -- the init proc of an ancestor which will not leave out the right tag + -- If the type is tagged, the tag needs to be initialized (unless we + -- are in VM-mode where tags are implicit). It is done late in the + -- initialization process because in some cases, we call the init + -- proc of an ancestor which will not leave out the right tag. if Ancestor_Is_Expression then null; @@ -3001,7 +3052,7 @@ package body Exp_Aggr is Append_To (L, Instr); - -- Ada 2005 (AI-251): If the tagged type has been derived from + -- Ada 2005 (AI-251): If the tagged type has been derived from an -- abstract interfaces we must also initialize the tags of the -- secondary dispatch tables. @@ -3337,16 +3388,16 @@ package body Exp_Aggr is or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) - -- (Ada 2005) An inherently limited type in a return statement, - -- which will be handled in a build-in-place fashion, and may be - -- rewritten as an extended return and have its own finalization - -- machinery. In the case of a simple return, the aggregate needs - -- to be delayed until the scope for the return statement has been - -- created, so that any finalization chain will be associated with - -- that scope. For extended returns, we delay expansion to avoid the - -- creation of an unwanted transient scope that could result in - -- premature finalization of the return object (which is built in - -- in place within the caller's scope). + -- (Ada 2005) An inherently limited type in a return statement, which + -- will be handled in a build-in-place fashion, and may be rewritten + -- as an extended return and have its own finalization machinery. + -- In the case of a simple return, the aggregate needs to be delayed + -- until the scope for the return statement has been created, so + -- that any finalization chain will be associated with that scope. + -- For extended returns, we delay expansion to avoid the creation + -- of an unwanted transient scope that could result in premature + -- finalization of the return object (which is built in in place + -- within the caller's scope). or else (Is_Limited_View (Typ) @@ -3363,9 +3414,9 @@ package body Exp_Aggr is end if; -- If the aggregate is non-limited, create a temporary. If it is limited - -- and the context is an assignment, this is a subaggregate for an - -- enclosing aggregate being expanded. It must be built in place, so use - -- the target of the current assignment. + -- 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. if Is_Limited_Type (Typ) and then Nkind (Parent (N)) = N_Assignment_Statement @@ -3382,7 +3433,7 @@ package body Exp_Aggr is -- known discriminants if available. if Has_Unknown_Discriminants (Typ) - and then Present (Underlying_Record_View (Typ)) + and then Present (Underlying_Record_View (Typ)) then T := Underlying_Record_View (Typ); else @@ -3450,6 +3501,8 @@ package body Exp_Aggr is -- Check_Static_Components -- ----------------------------- + -- Could use some comments in this body ??? + procedure Check_Static_Components is Expr : Node_Id; @@ -3487,7 +3540,7 @@ package body Exp_Aggr is elsif Is_Entity_Name (Expression (Expr)) and then Present (Entity (Expression (Expr))) and then Ekind (Entity (Expression (Expr))) = - E_Enumeration_Literal + E_Enumeration_Literal then null; @@ -3581,8 +3634,7 @@ package body Exp_Aggr is -- See ACATS c460010 for an example. if Hiv < Lov - or else (not Compile_Time_Known_Value (Blo) - and then Others_Present) + or else (not Compile_Time_Known_Value (Blo) and then Others_Present) then return False; end if; @@ -3636,7 +3688,7 @@ package body Exp_Aggr is if Present (Next_Index (Ix)) and then not Flatten - (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb)) + (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb)) then return False; end if; @@ -3679,9 +3731,8 @@ package body Exp_Aggr is or else Restriction_Active (No_Implicit_Loops) or else (Ekind (Current_Scope) = E_Package - and then - Static_Elaboration_Desired - (Current_Scope)) + and then Static_Elaboration_Desired + (Current_Scope)) or else Is_Preelaborated (P) or else (Ekind (P) = E_Package_Body and then @@ -3738,15 +3789,16 @@ package body Exp_Aggr is else Choice_Index := UI_To_Int (Expr_Value (Choice)); + if Choice_Index in Vals'Range then Vals (Choice_Index) := New_Copy_Tree (Expression (Elmt)); goto Continue; - else - -- Choice is statically out-of-range, will be - -- rewritten to raise Constraint_Error. + -- Choice is statically out-of-range, will be + -- rewritten to raise Constraint_Error. + else return False; end if; end if; @@ -3759,6 +3811,7 @@ package body Exp_Aggr is not Compile_Time_Known_Value (Hi) then return False; + else for J in UI_To_Int (Expr_Value (Lo)) .. UI_To_Int (Expr_Value (Hi)) @@ -3834,9 +3887,7 @@ package body Exp_Aggr is return; end if; - if Is_Bit_Packed_Array (Typ) - and then not Handle_Bit_Packed - then + if Is_Bit_Packed_Array (Typ) and then not Handle_Bit_Packed then return; end if; @@ -3962,6 +4013,9 @@ package body Exp_Aggr is Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id; -- The type of each index + In_Place_Assign_OK_For_Declaration : Boolean := False; + -- True if we are to generate an in place assignment for a declaration + Maybe_In_Place_OK : Boolean; -- If the type is neither controlled nor packed and the aggregate -- is the expression in an assignment, assignment in place may be @@ -3972,6 +4026,9 @@ package body Exp_Aggr is -- If Others_Present (J) is True, then there is an others choice -- in one of the sub-aggregates 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 + procedure Build_Constrained_Type (Positional : Boolean); -- If the subtype is not static or unconstrained, build a constrained -- type using the computable sizes of the aggregate and its sub- @@ -4008,6 +4065,142 @@ package body Exp_Aggr is -- built directly into the target of the assignment it must be free -- of side-effects. + ------------------------------------ + -- Aggr_Assignment_OK_For_Backend -- + ------------------------------------ + + -- Backend processing by Gigi/gcc is possible only if all the following + -- conditions are met: + + -- 1. N consists of a single OTHERS choice, possibly recursively + + -- 2. The array type is not packed + + -- 3. The array type has no atomic components + + -- 4. The array type has no null ranges (the purpose of this is to + -- avoid a bogus warning for an out-of-range value). + + -- 5. The component type is discrete + + -- 6. The component size is Storage_Unit or the value is of the form + -- M * (1 + A**1 + A**2 + .. A**(K-1)) where A = 2**(Storage_Unit) + -- and M in 1 .. A-1. This can also be viewed as K occurrences of + -- the 8-bit value M, concatenated together. + + -- The ultimate goal is to generate a call to a fast memset routine + -- specifically optimized for the target. + + function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean is + Ctyp : Entity_Id; + Index : Entity_Id; + Expr : Node_Id := N; + Low : Node_Id; + High : Node_Id; + Remainder : Uint; + Value : Uint; + Nunits : Nat; + + begin + -- Recurse as far as possible to find the innermost component type + + Ctyp := Etype (N); + while Is_Array_Type (Ctyp) loop + if Nkind (Expr) /= N_Aggregate + or else not Is_Others_Aggregate (Expr) + then + return False; + end if; + + if Present (Packed_Array_Impl_Type (Ctyp)) then + return False; + end if; + + if Has_Atomic_Components (Ctyp) then + return False; + end if; + + Index := First_Index (Ctyp); + while Present (Index) loop + Get_Index_Bounds (Index, Low, High); + + if Is_Null_Range (Low, High) then + return False; + end if; + + Next_Index (Index); + end loop; + + Expr := Expression (First (Component_Associations (Expr))); + + for J in 1 .. Number_Dimensions (Ctyp) - 1 loop + if Nkind (Expr) /= N_Aggregate + or else not Is_Others_Aggregate (Expr) + then + return False; + end if; + + Expr := Expression (First (Component_Associations (Expr))); + end loop; + + Ctyp := Component_Type (Ctyp); + + if Is_Atomic (Ctyp) then + return False; + end if; + end loop; + + if not Is_Discrete_Type (Ctyp) then + return False; + end if; + + -- The expression needs to be analyzed if True is returned + + Analyze_And_Resolve (Expr, Ctyp); + + -- The back end uses the Esize as the precision of the type + + Nunits := UI_To_Int (Esize (Ctyp)) / System_Storage_Unit; + + if Nunits = 1 then + return True; + end if; + + if not Compile_Time_Known_Value (Expr) then + return False; + end if; + + Value := Expr_Value (Expr); + + if Has_Biased_Representation (Ctyp) then + Value := Value - Expr_Value (Type_Low_Bound (Ctyp)); + end if; + + -- Values 0 and -1 immediately satisfy the last check + + if Value = Uint_0 or else Value = Uint_Minus_1 then + return True; + end if; + + -- We need to work with an unsigned value + + if Value < 0 then + Value := Value + 2**(System_Storage_Unit * Nunits); + end if; + + Remainder := Value rem 2**System_Storage_Unit; + + for J in 1 .. Nunits - 1 loop + Value := Value / 2**System_Storage_Unit; + + if Value rem 2**System_Storage_Unit /= Remainder then + return False; + end if; + end loop; + + return True; + end Aggr_Assignment_OK_For_Backend; + ---------------------------- -- Build_Constrained_Type -- ---------------------------- @@ -4042,7 +4235,7 @@ package body Exp_Aggr is Append_To (Indexes, Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, 1), + Low_Bound => Make_Integer_Literal (Loc, 1), High_Bound => Make_Integer_Literal (Loc, Num))); end loop; @@ -4052,18 +4245,17 @@ package body Exp_Aggr is -- positional. Retrieve each dimension bounds (computed earlier). for D in 1 .. Number_Dimensions (Typ) loop - Append ( + Append_To (Indexes, Make_Range (Loc, - Low_Bound => Aggr_Low (D), - High_Bound => Aggr_High (D)), - Indexes); + Low_Bound => Aggr_Low (D), + High_Bound => Aggr_High (D))); end loop; end if; Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Agg_Type, - Type_Definition => + Type_Definition => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => Indexes, Component_Definition => @@ -4097,7 +4289,7 @@ package body Exp_Aggr is Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi); -- Generate the following test: - -- + -- [constraint_error when -- Aggr_Lo <= Aggr_Hi and then -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] @@ -4187,8 +4379,7 @@ package body Exp_Aggr is if Index_Checks_Suppressed (Ind_Typ) then Cond := Empty; - elsif Dim = 1 - or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) + elsif Dim = 1 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) then Cond := Empty; @@ -4388,7 +4579,7 @@ package body Exp_Aggr is return Compile_Time_Known_Value (Comp) or else (Is_Entity_Name (Comp) - and then Present (Entity (Comp)) + and then Present (Entity (Comp)) and then No (Renamed_Object (Entity (Comp)))) or else (Nkind (Comp) = N_Attribute_Reference @@ -4411,12 +4602,12 @@ package body Exp_Aggr is -- Start of processing for Safe_Component begin - -- If the component appears in an association that may - -- correspond to more than one element, it is not analyzed - -- before the expansion into assignments, to avoid side effects. - -- We analyze, but do not resolve the copy, to obtain sufficient - -- entity information for the checks that follow. If component is - -- overloaded we assume an unsafe function call. + -- If the component appears in an association that may correspond + -- to more than one element, it is not analyzed before expansion + -- into assignments, to avoid side effects. We analyze, but do not + -- resolve the copy, to obtain sufficient entity information for + -- the checks that follow. If component is overloaded we assume + -- an unsafe function call. if not Analyzed (Comp) then if Is_Overloaded (Expr) then @@ -4455,9 +4646,9 @@ package body Exp_Aggr is -- assignment in place unless the bounds of the aggregate are -- statically equal to those of the target. - -- If the aggregate is given by an others choice, the bounds - -- are derived from the left-hand side, and the assignment is - -- safe if the expression is. + -- If the aggregate is given by an others choice, the bounds are + -- derived from the left-hand side, and the assignment is safe if + -- the expression is. if Is_Others_Aggregate (N) then return @@ -4471,8 +4662,8 @@ package body Exp_Aggr is Obj_In := First_Index (Etype (Name (Parent (N)))); else - -- Context is an allocator. Check bounds of aggregate - -- against given type in qualified expression. + -- Context is an allocator. Check bounds of aggregate against + -- given type in qualified expression. pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator); Obj_In := @@ -4556,6 +4747,8 @@ package body Exp_Aggr is -- Count the number of discrete choices. Start with -1 because -- the others choice does not count. + -- Is there some reason we do not use List_Length here ??? + Nb_Choices := -1; Assoc := First (Component_Associations (Sub_Aggr)); while Present (Assoc) loop @@ -4657,7 +4850,7 @@ package body Exp_Aggr is Expressions => New_List (Duplicate_Subexpr_Move_Checks (Aggr_Lo))), - Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), + Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), Right_Opnd => Make_Attribute_Reference (Loc, @@ -4677,17 +4870,13 @@ package body Exp_Aggr is Make_Or_Else (Loc, Left_Opnd => Make_Op_Lt (Loc, - Left_Opnd => - Duplicate_Subexpr_Move_Checks (Choices_Lo), - Right_Opnd => - Duplicate_Subexpr_Move_Checks (Aggr_Lo)), + Left_Opnd => Duplicate_Subexpr_Move_Checks (Choices_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo)), Right_Opnd => Make_Op_Gt (Loc, - Left_Opnd => - Duplicate_Subexpr (Choices_Hi), - Right_Opnd => - Duplicate_Subexpr (Aggr_Hi))); + Left_Opnd => Duplicate_Subexpr (Choices_Hi), + Right_Opnd => Duplicate_Subexpr (Aggr_Hi))); end if; if Present (Cond) then @@ -4749,8 +4938,7 @@ package body Exp_Aggr is elsif Nkind (Indx) = N_Function_Call and then Is_Entity_Name (Name (Indx)) - and then - Has_Pragma_Pure_Function (Entity (Name (Indx))) + and then Has_Pragma_Pure_Function (Entity (Name (Indx))) then return True; @@ -4777,8 +4965,7 @@ package body Exp_Aggr is elsif Nkind (N) = N_Indexed_Component and then Safe_Left_Hand_Side (Prefix (N)) - and then - Is_Safe_Index (First (Expressions (N))) + and then Is_Safe_Index (First (Expressions (N))) then return True; @@ -4826,6 +5013,13 @@ package body Exp_Aggr is (Return_Applies_To (Return_Statement_Entity (Parent (N)))) then return; + + -- Do not attempt expansion if error already detected. We may reach this + -- point in spite of previous errors when compiling with -gnatq, to + -- force all possible errors (this is the usual ACATS mode). + + elsif Error_Posted (N) then + return; end if; -- If the semantic analyzer has determined that aggregate N will raise @@ -4852,12 +5046,12 @@ package body Exp_Aggr is Compute_Others_Present (N, 1); 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 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). + -- 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 + -- 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). if not Range_Checks_Suppressed (Etype (Index_Constraint)) and then not Others_Present (J) @@ -4968,9 +5162,7 @@ package body Exp_Aggr is -- that Convert_To_Positional succeeded and reanalyzed the rewritten -- aggregate. - elsif Analyzed (N) - and then N /= Original_Node (N) - then + elsif Analyzed (N) and then N /= Original_Node (N) then return; end if; @@ -5003,7 +5195,7 @@ package body Exp_Aggr is begin Index := First_Index (Itype); while Present (Index) loop - if not Is_Static_Subtype (Etype (Index)) then + if not Is_OK_Static_Subtype (Etype (Index)) then Needs_Type := True; exit; else @@ -5086,11 +5278,10 @@ package body Exp_Aggr is else Maybe_In_Place_OK := (Nkind (Parent (N)) = N_Assignment_Statement - and then Comes_From_Source (N) and then In_Place_Assign_OK) - or else - (Nkind (Parent (Parent (N))) = N_Allocator + or else + (Nkind (Parent (Parent (N))) = N_Allocator and then In_Place_Assign_OK); end if; @@ -5119,22 +5310,27 @@ package body Exp_Aggr is and then not Is_Bit_Packed_Array (Typ) and then not Has_Controlled_Component (Typ) then + In_Place_Assign_OK_For_Declaration := True; Tmp := Defining_Identifier (Parent (N)); Set_No_Initialization (Parent (N)); Set_Expression (Parent (N), Empty); - -- Set the type of the entity, for use in the analysis of the - -- subsequent indexed assignments. If the nominal type is not + -- Set kind and type of the entity, for use in the analysis + -- of the subsequent assignments. If the nominal type is not -- constrained, build a subtype from the known bounds of the -- aggregate. If the declaration has a subtype mark, use it, -- otherwise use the itype of the aggregate. + Set_Ekind (Tmp, E_Variable); + 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)))) then Set_Etype (Tmp, Entity (Object_Definition (Parent (N)))); + else Set_Size_Known_At_Compile_Time (Typ, False); Set_Etype (Tmp, Typ); @@ -5165,13 +5361,20 @@ package body Exp_Aggr is end if; end if; + -- If a slice assignment has an aggregate with a single others_choice, + -- the assignment can be done in place even if bounds are not static, + -- by converting it into a loop over the discrete range of the slice. + elsif Maybe_In_Place_OK and then Nkind (Name (Parent (N))) = N_Slice - and then Safe_Slice_Assignment (N) + and then Is_Others_Aggregate (N) then - -- Safe_Slice_Assignment rewrites assignment as a loop + Tmp := Name (Parent (N)); - return; + -- Set type of aggregate to be type of lhs in assignment, in order + -- to suppress redundant length checks. + + Set_Etype (N, Etype (Tmp)); -- Step 5 @@ -5181,10 +5384,9 @@ package body Exp_Aggr is Maybe_In_Place_OK := False; Tmp := Make_Temporary (Loc, 'A', N); Tmp_Decl := - Make_Object_Declaration - (Loc, - Defining_Identifier => Tmp, - Object_Definition => New_Occurrence_Of (Typ, Loc)); + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); Set_No_Initialization (Tmp_Decl, True); -- If we are within a loop, the temporary will be pushed on the @@ -5214,7 +5416,6 @@ package body Exp_Aggr is Target := New_Occurrence_Of (Tmp, Loc); else - if Has_Default_Init_Comps (N) then -- Ada 2005 (AI-287): This case has not been analyzed??? @@ -5227,12 +5428,39 @@ package body Exp_Aggr is Target := New_Copy (Tmp); end if; - Aggr_Code := - Build_Array_Aggr_Code (N, - Ctype => Ctyp, - Index => First_Index (Typ), - Into => Target, - Scalar_Comp => Is_Scalar_Type (Ctyp)); + -- If we are to generate an in place assignment for a declaration or + -- an assignment statement, and the assignment can be done directly + -- by the back end, then do not expand further. + + -- ??? We can also do that if in place expansion is not possible but + -- then we could go into an infinite recursion. + + if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK) + and then VM_Target = No_VM + and then not AAMP_On_Target + and then not Generate_SCIL + and then not Possible_Bit_Aligned_Component (Target) + and then not Is_Possibly_Unaligned_Slice (Target) + and then Aggr_Assignment_OK_For_Backend (N) + then + if Maybe_In_Place_OK then + return; + end if; + + Aggr_Code := + New_List ( + Make_Assignment_Statement (Loc, + Name => Target, + Expression => New_Copy (N))); + + else + Aggr_Code := + Build_Array_Aggr_Code (N, + Ctype => Ctyp, + Index => First_Index (Typ), + Into => Target, + Scalar_Comp => Is_Scalar_Type (Ctyp)); + end if; -- Save the last assignment statement associated with the aggregate -- when building a controlled object. This reference is utilized by @@ -5395,6 +5623,7 @@ package body Exp_Aggr is Expand_Array_Aggregate (N); end if; + exception when RE_Not_Available => return; @@ -5676,11 +5905,11 @@ package body Exp_Aggr is -- Start of processing for Expand_Record_Aggregate begin - -- If the aggregate is to be assigned to an atomic variable, we - -- have to prevent a piecemeal assignment even if the aggregate - -- is to be expanded. We create a temporary for the aggregate, and - -- assign the temporary instead, so that the back end can generate - -- an atomic move for it. + -- If the aggregate is to be assigned to an atomic variable, we have + -- to prevent a piecemeal assignment even if the aggregate is to be + -- expanded. We create a temporary for the aggregate, and assign the + -- temporary instead, so that the back end can generate an atomic move + -- for it. if Is_Atomic (Typ) and then Comes_From_Source (Parent (N)) @@ -5843,9 +6072,9 @@ package body Exp_Aggr is New_List (New_Occurrence_Of (Discriminant, Loc)), Expression => - New_Copy_Tree ( - Get_Discriminant_Value ( - Discriminant, + New_Copy_Tree + (Get_Discriminant_Value + (Discriminant, Typ, Discriminant_Constraint (Typ)))); @@ -5870,8 +6099,7 @@ package body Exp_Aggr is Comp := First_Comp; Next (First_Comp); - if Ekind (Entity - (First (Choices (Comp)))) = E_Discriminant + if Ekind (Entity (First (Choices (Comp)))) = E_Discriminant then Remove (Comp); Num_Disc := Num_Disc + 1; @@ -5906,9 +6134,9 @@ package body Exp_Aggr is Discriminant := First_Stored_Discriminant (Base_Type (Typ)); while Present (Discriminant) loop New_Comp := - New_Copy_Tree ( - Get_Discriminant_Value ( - Discriminant, + New_Copy_Tree + (Get_Discriminant_Value + (Discriminant, Typ, Discriminant_Constraint (Typ))); Append (New_Comp, Constraints); @@ -5918,11 +6146,11 @@ package body Exp_Aggr is Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'T'), - Subtype_Indication => + Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints))); @@ -5958,34 +6186,29 @@ package body Exp_Aggr is -- 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 + 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)) + if not Comes_From_Source (Original_Record_Component (Comp)) then null; else New_Comp := Make_Selected_Component (Loc, - Prefix => + 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)); + Expression => New_Comp)); Analyze_And_Resolve (New_Comp, Etype (Comp)); end if; @@ -6026,8 +6249,10 @@ package body Exp_Aggr is 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 + and then + Scope (Original_Record_Component + (Entity (First (Choices (First_Comp))))) /= + Base_Typ loop Comp := First_Comp; Next (First_Comp); @@ -6035,8 +6260,9 @@ package body Exp_Aggr is Append (Comp, Parent_Comps); end loop; - Parent_Aggr := Make_Aggregate (Loc, - Component_Associations => Parent_Comps); + Parent_Aggr := + Make_Aggregate (Loc, + Component_Associations => Parent_Comps); Set_Etype (Parent_Aggr, Etype (Base_Type (Typ))); -- Find the _parent component @@ -6100,6 +6326,7 @@ package body Exp_Aggr is Comps : constant List_Id := Component_Associations (N); C : Node_Id; Expr : Node_Id; + begin pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); @@ -6129,8 +6356,7 @@ package body Exp_Aggr is Expr := Expression (C); if Present (Expr) - and then - Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) + and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate) and then Has_Default_Init_Comps (Expr) then return True; @@ -6156,7 +6382,7 @@ package body Exp_Aggr is Kind := Nkind (Node); end if; - if Kind /= N_Aggregate and then Kind /= N_Extension_Aggregate then + if not Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate) then return False; else return Expansion_Delayed (Node); @@ -6261,7 +6487,6 @@ package body Exp_Aggr is is begin Set_Assignment_OK (Name); - return Make_Assignment_Statement (Sloc, Name, Expression); end Make_OK_Assignment_Statement; @@ -6591,8 +6816,8 @@ package body Exp_Aggr is and then Number_Discriminants (Bas) /= Number_Discriminants (Par) and then Nkind (Decl) = N_Full_Type_Declaration and then Nkind (Type_Definition (Decl)) = N_Record_Definition - and then Present - (Variant_Part (Component_List (Type_Definition (Decl)))) + and then + Present (Variant_Part (Component_List (Type_Definition (Decl)))) and then Nkind (N) /= N_Extension_Aggregate then @@ -6614,6 +6839,7 @@ package body Exp_Aggr is Typ : Entity_Id) return Boolean is L1, L2, H1, H2 : Node_Id; + begin -- No sliding if the type of the object is not established yet, if it is -- an unconstrained type whose actual subtype comes from the aggregate, @@ -6634,10 +6860,10 @@ package body Exp_Aggr is Get_Index_Bounds (First_Index (Typ), L1, H1); Get_Index_Bounds (First_Index (Obj_Type), L2, H2); - if not Is_Static_Expression (L1) - or else not Is_Static_Expression (L2) - or else not Is_Static_Expression (H1) - or else not Is_Static_Expression (H2) + if not Is_OK_Static_Expression (L1) or else + not Is_OK_Static_Expression (L2) or else + not Is_OK_Static_Expression (H1) or else + not Is_OK_Static_Expression (H2) then return False; else @@ -6648,70 +6874,6 @@ package body Exp_Aggr is end if; end Must_Slide; - --------------------------- - -- Safe_Slice_Assignment -- - --------------------------- - - function Safe_Slice_Assignment (N : Node_Id) return Boolean is - Loc : constant Source_Ptr := Sloc (Parent (N)); - Pref : constant Node_Id := Prefix (Name (Parent (N))); - Range_Node : constant Node_Id := Discrete_Range (Name (Parent (N))); - Expr : Node_Id; - L_J : Entity_Id; - L_Iter : Node_Id; - L_Body : Node_Id; - Stat : Node_Id; - - begin - -- Generate: for J in Range loop Pref (J) := Expr; end loop; - - if Comes_From_Source (N) - and then No (Expressions (N)) - and then Nkind (First (Choices (First (Component_Associations (N))))) - = N_Others_Choice - then - Expr := Expression (First (Component_Associations (N))); - L_J := Make_Temporary (Loc, 'J'); - - L_Iter := - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification - (Loc, - Defining_Identifier => L_J, - Discrete_Subtype_Definition => Relocate_Node (Range_Node))); - - L_Body := - Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Pref), - Expressions => New_List (New_Occurrence_Of (L_J, Loc))), - Expression => Relocate_Node (Expr)); - - -- Construct the final loop - - Stat := - Make_Implicit_Loop_Statement - (Node => Parent (N), - Identifier => Empty, - Iteration_Scheme => L_Iter, - Statements => New_List (L_Body)); - - -- Set type of aggregate to be type of lhs in assignment, - -- to suppress redundant length checks. - - Set_Etype (N, Etype (Name (Parent (N)))); - - Rewrite (Parent (N), Stat); - Analyze (Parent (N)); - return True; - - else - return False; - end if; - end Safe_Slice_Assignment; - ---------------------------------- -- Two_Dim_Packed_Array_Handled -- ---------------------------------- @@ -6724,10 +6886,10 @@ package body Exp_Aggr is Packed_Array : constant Entity_Id := Packed_Array_Impl_Type (Base_Type (Typ)); - One_Comp : Node_Id; + One_Comp : Node_Id; -- Expression in original aggregate - One_Dim : Node_Id; + One_Dim : Node_Id; -- One-dimensional subaggregate begin @@ -6830,14 +6992,12 @@ package body Exp_Aggr is Incr := +Comp_Size; end if; - Shift := Init_Shift; - One_Dim := First (Expressions (N)); - -- 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 @@ -6879,8 +7039,7 @@ package body Exp_Aggr is Unchecked_Convert_To (Typ, Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), - Expression => - Make_Aggregate (Loc, Expressions => Comps)))); + Expression => Make_Aggregate (Loc, Expressions => Comps)))); Analyze_And_Resolve (N); return True; end; @@ -7007,8 +7166,7 @@ package body Exp_Aggr is for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi)) loop - Append_To - (Expressions (Agg), New_Copy (Expression (Expr))); + Append_To (Expressions (Agg), New_Copy (Expression (Expr))); -- The copied expression must be analyzed and resolved. -- Besides setting the type, this ensures that static diff --git a/main/gcc/ada/exp_atag.adb b/main/gcc/ada/exp_atag.adb index 36e7dc6abcf..bd5f9e26eca 100644 --- a/main/gcc/ada/exp_atag.adb +++ b/main/gcc/ada/exp_atag.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 +99,11 @@ package body Exp_Atag is Append_To (Stmts, Make_Assignment_Statement (Loc, - Name => Make_Identifier (Loc, Name_uC), + Name => Make_Identifier (Loc, Name_uC), Expression => Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), + Name => + New_Occurrence_Of (RTE (RE_Get_Prim_Op_Kind), Loc), Parameter_Associations => New_List ( Tag_Node, Make_Identifier (Loc, Name_uS))))); @@ -415,9 +416,9 @@ package body Exp_Atag is Append_To (Result, Make_Assignment_Statement (Loc, - Name => + Name => Make_Indexed_Component (Loc, - Prefix => + Prefix => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (Typ))), @@ -428,7 +429,7 @@ package body Exp_Atag is Expression => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (E, Loc), + Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; @@ -455,7 +456,7 @@ package body Exp_Atag is if not CPP_Table (J) then Prepend_To (Result, Make_Assignment_Statement (Loc, - Name => + Name => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (CPP_Typ))), @@ -550,14 +551,14 @@ package body Exp_Atag is Append_To (Result, Make_Assignment_Statement (Loc, - Name => + Name => Make_Indexed_Component (Loc, - Prefix => + Prefix => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt - (Access_Disp_Table (Iface))), + (Access_Disp_Table (Iface))), New_Occurrence_Of (Typ_Tag, Loc))), Expressions => New_List @@ -566,7 +567,7 @@ package body Exp_Atag is Expression => Unchecked_Convert_To (RTE (RE_Prim_Ptr), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (E, Loc), + Prefix => New_Occurrence_Of (E, Loc), Attribute_Name => Name_Unrestricted_Access)))); end if; @@ -584,7 +585,7 @@ package body Exp_Atag is if not Prims_Table (J) then Insert_After (Last_Nod, Make_Assignment_Statement (Loc, - Name => + Name => Make_Explicit_Dereference (Loc, Unchecked_Convert_To (Node (Last_Elmt (Access_Disp_Table (Iface))), diff --git a/main/gcc/ada/exp_attr.adb b/main/gcc/ada/exp_attr.adb index 0232d67e0c6..d2cd8e4fcfb 100644 --- a/main/gcc/ada/exp_attr.adb +++ b/main/gcc/ada/exp_attr.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; @@ -38,7 +39,6 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Exp_VFpt; use Exp_VFpt; with Fname; use Fname; with Freeze; use Freeze; with Gnatvsn; use Gnatvsn; @@ -84,6 +84,14 @@ package body Exp_Attr is -- value returned is the entity of the constructed function body. We do not -- bother to generate a separate spec for this subprogram. + function Build_Record_VS_Func + (R_Type : Entity_Id; + Nod : Node_Id) return Entity_Id; + -- Build function to test Valid_Scalars for record type A_Type. Nod is the + -- Valid_Scalars attribute node, used to insert the function body, and the + -- value returned is the entity of the constructed function body. We do not + -- bother to generate a separate spec for this subprogram. + procedure Compile_Stream_Body_In_Scope (N : Node_Id; Decl : Node_Id; @@ -98,6 +106,8 @@ package body Exp_Attr is -- We suppress checks for array/record reads, since the rule is that these -- are like assignments, out of range values due to uninitialized storage, -- or other invalid values do NOT cause a Constraint_Error to be raised. + -- If we are within an instance body all visibility has been established + -- already and there is no need to install the package. procedure Expand_Access_To_Protected_Op (N : Node_Id; @@ -202,10 +212,10 @@ package body Exp_Attr is Nod : Node_Id) return Entity_Id is Loc : constant Source_Ptr := Sloc (Nod); + Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V'); Comp_Type : constant Entity_Id := Component_Type (A_Type); Body_Stmts : List_Id; Index_List : List_Id; - Func_Id : Entity_Id; Formals : List_Id; function Test_Component return List_Id; @@ -298,8 +308,6 @@ package body Exp_Attr is begin Index_List := New_List; - Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); - Body_Stmts := Test_One_Dimension (1); -- Parameter is always (A : A_Typ) @@ -333,9 +341,279 @@ package body Exp_Attr is Set_Debug_Info_Off (Func_Id); end if; + Set_Is_Pure (Func_Id); return Func_Id; end Build_Array_VS_Func; + -------------------------- + -- Build_Record_VS_Func -- + -------------------------- + + -- Generates: + + -- function _Valid_Scalars (X : T) return Boolean is + -- begin + -- -- Check discriminants + + -- if not X.D1'Valid_Scalars or else + -- not X.D2'Valid_Scalars or else + -- ... + -- then + -- return False; + -- end if; + + -- -- Check components + + -- if not X.C1'Valid_Scalars or else + -- not X.C2'Valid_Scalars or else + -- ... + -- then + -- return False; + -- end if; + + -- -- Check variant part + + -- case X.D1 is + -- when V1 => + -- if not X.C2'Valid_Scalars or else + -- not X.C3'Valid_Scalars or else + -- ... + -- then + -- return False; + -- end if; + -- ... + -- when Vn => + -- if not X.Cn'Valid_Scalars or else + -- ... + -- then + -- return False; + -- end if; + -- end case; + + -- return True; + -- end _Valid_Scalars; + + function Build_Record_VS_Func + (R_Type : Entity_Id; + Nod : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (R_Type); + Func_Id : constant Entity_Id := Make_Temporary (Loc, 'V'); + X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); + + function Make_VS_Case + (E : Entity_Id; + CL : Node_Id; + Discrs : Elist_Id := New_Elmt_List) return List_Id; + -- Building block for variant valid scalars. Given a Component_List node + -- CL, it generates an 'if' followed by a 'case' statement that compares + -- all components of local temporaries named X and Y (that are declared + -- as formals at some upper level). E provides the Sloc to be used for + -- the generated code. + + function Make_VS_If + (E : Entity_Id; + L : List_Id) return Node_Id; + -- Building block for variant validate scalars. Given the list, L, of + -- components (or discriminants) L, it generates a return statement that + -- compares all components of local temporaries named X and Y (that are + -- declared as formals at some upper level). E provides the Sloc to be + -- used for the generated code. + + ------------------ + -- Make_VS_Case -- + ------------------ + + -- + + -- case X.D1 is + -- when V1 => on subcomponents + -- ... + -- when Vn => on subcomponents + -- end case; + + function Make_VS_Case + (E : Entity_Id; + CL : Node_Id; + Discrs : Elist_Id := New_Elmt_List) return List_Id + is + Loc : constant Source_Ptr := Sloc (E); + Result : constant List_Id := New_List; + Variant : Node_Id; + Alt_List : List_Id; + + begin + Append_To (Result, Make_VS_If (E, Component_Items (CL))); + + if No (Variant_Part (CL)) then + return Result; + end if; + + Variant := First_Non_Pragma (Variants (Variant_Part (CL))); + + if No (Variant) then + return Result; + end if; + + Alt_List := New_List; + while Present (Variant) loop + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)), + Statements => + Make_VS_Case (E, Component_List (Variant), Discrs))); + Next_Non_Pragma (Variant); + end loop; + + Append_To (Result, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => Make_Identifier (Loc, Name_X), + Selector_Name => New_Copy (Name (Variant_Part (CL)))), + Alternatives => Alt_List)); + + return Result; + end Make_VS_Case; + + ---------------- + -- Make_VS_If -- + ---------------- + + -- Generates: + + -- if + -- not X.C1'Valid_Scalars + -- or else + -- not X.C2'Valid_Scalars + -- ... + -- then + -- return False; + -- end if; + + -- or a null statement if the list L is empty + + function Make_VS_If + (E : Entity_Id; + L : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (E); + C : Node_Id; + Def_Id : Entity_Id; + Field_Name : Name_Id; + Cond : Node_Id; + + begin + if No (L) then + return Make_Null_Statement (Loc); + + else + Cond := Empty; + + C := First_Non_Pragma (L); + while Present (C) loop + Def_Id := Defining_Identifier (C); + Field_Name := Chars (Def_Id); + + -- The tags need not be checked since they will always be valid + + -- Note also that in the following, we use Make_Identifier for + -- the component names. Use of New_Occurrence_Of to identify + -- the components would be incorrect because wrong entities for + -- discriminants could be picked up in the private type case. + + -- Don't bother with abstract parent in interface case + + if Field_Name = Name_uParent + and then Is_Interface (Etype (Def_Id)) + then + null; + + -- Don't bother with tag, always valid, and not scalar anyway + + elsif Field_Name = Name_uTag then + null; + + -- Don't bother with component with no scalar components + + elsif not Scalar_Part_Present (Etype (Def_Id)) then + null; + + -- Normal case, generate Valid_Scalars attribute reference + + else + Evolve_Or_Else (Cond, + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Name_X), + Selector_Name => + Make_Identifier (Loc, Field_Name)), + Attribute_Name => Name_Valid_Scalars))); + end if; + + Next_Non_Pragma (C); + end loop; + + if No (Cond) then + return Make_Null_Statement (Loc); + + else + return + Make_Implicit_If_Statement (E, + Condition => Cond, + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Standard_False, Loc)))); + end if; + end if; + end Make_VS_If; + + -- Local Declarations + + 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; + + begin + Append_To (Pspecs, + Make_Parameter_Specification (Loc, + Defining_Identifier => X, + Parameter_Type => New_Occurrence_Of (R_Type, Loc))); + + Append_To (Stmts, + Make_VS_If (R_Type, Discriminant_Specifications (Def))); + Append_List_To (Stmts, Make_VS_Case (R_Type, Comps)); + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))); + + Insert_Action (Nod, + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Id, + Parameter_Specifications => Pspecs, + Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)), + Suppress => Discriminant_Check); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + Set_Is_Pure (Func_Id); + return Func_Id; + end Build_Record_VS_Func; + ---------------------------------- -- Compile_Stream_Body_In_Scope -- ---------------------------------- @@ -354,6 +632,11 @@ package body Exp_Attr is if Is_Hidden (Arr) and then not In_Open_Scopes (Scop) and then Ekind (Scop) = E_Package + + -- If we are within an instance body, then all visibility has been + -- established already and there is no need to install the package. + + and then not In_Instance_Body then Push_Scope (Scop); Install_Visible_Declarations (Scop); @@ -837,7 +1120,13 @@ package body Exp_Attr is -- While loops are transformed into: - -- if then + -- function Fnn return Boolean is + -- begin + -- + -- return ; + -- end Fnn; + + -- if Fnn then -- declare -- Temp1 : constant := ; -- . . . @@ -845,7 +1134,7 @@ package body Exp_Attr is -- begin -- loop -- - -- exit when not ; + -- exit when not Fnn; -- end loop; -- end; -- end if; @@ -855,23 +1144,81 @@ package body Exp_Attr is elsif Present (Condition (Scheme)) then declare - Cond : constant Node_Id := Condition (Scheme); + Func_Decl : Node_Id; + Func_Id : Entity_Id; + Stmts : List_Id; begin + -- Wrap the condition of the while loop in a Boolean function. + -- This avoids the duplication of the same code which may lead + -- to gigi issues with respect to multiple declaration of the + -- same entity in the presence of side effects or checks. Note + -- that the condition actions must also be relocated to the + -- wrapping function. + + -- Generate: + -- + -- return ; + + if Present (Condition_Actions (Scheme)) then + Stmts := Condition_Actions (Scheme); + else + Stmts := New_List; + end if; + + Append_To (Stmts, + Make_Simple_Return_Statement (Loc, + Expression => Relocate_Node (Condition (Scheme)))); + + -- Generate: + -- function Fnn return Boolean is + -- begin + -- + -- end Fnn; + + Func_Id := Make_Temporary (Loc, 'F'); + Func_Decl := + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Id, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + + -- The function is inserted before the related loop. Make sure + -- to analyze it in the context of the loop's enclosing scope. + + Push_Scope (Scope (Loop_Id)); + Insert_Action (Loop_Stmt, Func_Decl); + Pop_Scope; + -- Transform the original while loop into an infinite loop -- where the last statement checks the negated condition. This -- placement ensures that the condition will not be evaluated -- twice on the first iteration. + Set_Iteration_Scheme (Loop_Stmt, Empty); + Scheme := Empty; + -- Generate: - -- exit when not : + -- exit when not Fnn; Append_To (Statements (Loop_Stmt), Make_Exit_Statement (Loc, - Condition => Make_Op_Not (Loc, New_Copy_Tree (Cond)))); + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func_Id, Loc))))); Build_Conditional_Block (Loc, - Cond => Relocate_Node (Cond), + Cond => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func_Id, Loc)), Loop_Stmt => Relocate_Node (Loop_Stmt), If_Stmt => Result, Blk_Stmt => Blk); @@ -1006,8 +1353,6 @@ package body Exp_Attr is -- Step 4: Analyze all bits - Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); - Installed := Current_Scope = Scope (Loop_Id); -- Depending on the pracement of attribute 'Loop_Entry relative to the @@ -1022,19 +1367,6 @@ package body Exp_Attr is if Present (Result) then Rewrite (Loop_Stmt, Result); - - -- The insertion of condition actions associated with an iteration - -- scheme is usually done by the expansion of loop statements. The - -- expansion of Loop_Entry however reuses the iteration scheme to - -- build an if statement. As a result any condition actions must be - -- inserted before the if statement to avoid references before - -- declaration. - - if Present (Scheme) and then Present (Condition_Actions (Scheme)) then - Insert_Actions (Loop_Stmt, Condition_Actions (Scheme)); - Set_Condition_Actions (Scheme, No_List); - end if; - Analyze (Loop_Stmt); -- The conditional block was analyzed when a previous 'Loop_Entry was @@ -1045,6 +1377,7 @@ package body Exp_Attr is Analyze (Temp_Decl); end if; + Rewrite (N, New_Occurrence_Of (Temp_Id, Loc)); Analyze (N); if not Installed then @@ -1922,70 +2255,6 @@ package body Exp_Attr is end if; end Alignment; - --------------- - -- AST_Entry -- - --------------- - - when Attribute_AST_Entry => AST_Entry : declare - Ttyp : Entity_Id; - T_Id : Node_Id; - Eent : Entity_Id; - - Entry_Ref : Node_Id; - -- The reference to the entry or entry family - - Index : Node_Id; - -- The index expression for an entry family reference, or - -- the Empty if Entry_Ref references a simple entry. - - begin - if Nkind (Pref) = N_Indexed_Component then - Entry_Ref := Prefix (Pref); - Index := First (Expressions (Pref)); - else - Entry_Ref := Pref; - Index := Empty; - end if; - - -- Get expression for Task_Id and the entry entity - - if Nkind (Entry_Ref) = N_Selected_Component then - T_Id := - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Identity, - Prefix => Prefix (Entry_Ref)); - - Ttyp := Etype (Prefix (Entry_Ref)); - Eent := Entity (Selector_Name (Entry_Ref)); - - else - T_Id := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc)); - - Eent := Entity (Entry_Ref); - - -- We have to find the enclosing task to get the task type - -- There must be one, since we already validated this earlier - - Ttyp := Current_Scope; - while not Is_Task_Type (Ttyp) loop - Ttyp := Scope (Ttyp); - end loop; - end if; - - -- Now rewrite the attribute with a call to Create_AST_Handler - - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc), - Parameter_Associations => New_List ( - T_Id, - Entry_Index_Expression (Loc, Eent, Index, Ttyp)))); - - Analyze_And_Resolve (N, RTE (RE_AST_Handler)); - end AST_Entry; - --------- -- Bit -- --------- @@ -2872,11 +3141,28 @@ package body Exp_Attr is Rewrite (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc))); + Prefix => + New_Occurrence_Of (Get_Index_Subtype (N), Loc))); Analyze_And_Resolve (N, Typ); + -- For access type, apply access check as needed + elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); + + -- For scalar type, if low bound is a reference to an entity, just + -- replace with a direct reference. Note that we can only have a + -- reference to a constant entity at this stage, anything else would + -- have already been rewritten. + + elsif Is_Scalar_Type (Ptyp) then + declare + Lo : constant Node_Id := Type_Low_Bound (Ptyp); + begin + if Is_Entity_Name (Lo) then + Rewrite (N, New_Occurrence_Of (Entity (Lo), Loc)); + end if; + end; end if; --------------- @@ -3246,13 +3532,10 @@ package body Exp_Attr is -- container). In that case rewrite the attribute as a Raise to -- prevent any run-time use. - -- This is not an explicit raise, the Reason code is wrong, we most - -- likely need a new Reason code ??? - if Restriction_Active (No_Streams) then Rewrite (N, Make_Raise_Program_Error (Sloc (N), - Reason => PE_Explicit_Raise)); + Reason => PE_Stream_Operation_Not_Allowed)); Set_Etype (N, B_Type); return; end if; @@ -3538,8 +3821,24 @@ package body Exp_Attr is Prefix => New_Occurrence_Of (Get_Index_Subtype (N), Loc))); Analyze_And_Resolve (N, Typ); + -- For access type, apply access check as needed + elsif Is_Access_Type (Ptyp) then Apply_Access_Check (N); + + -- For scalar type, if low bound is a reference to an entity, just + -- replace with a direct reference. Note that we can only have a + -- reference to a constant entity at this stage, anything else would + -- have already been rewritten. + + elsif Is_Scalar_Type (Ptyp) then + declare + Hi : constant Node_Id := Type_High_Bound (Ptyp); + begin + if Is_Entity_Name (Hi) then + Rewrite (N, New_Occurrence_Of (Entity (Hi), Loc)); + end if; + end; end if; -------------- @@ -3770,10 +4069,13 @@ package body Exp_Attr is ------------- -- Transforms 'Machine into a call to the floating-point attribute - -- function Machine in Fat_xxx (where xxx is the root type) + -- function Machine in Fat_xxx (where xxx is the root type). + -- Expansion is avoided for cases the back end can handle directly. when Attribute_Machine => - Expand_Fpt_Attribute_R (N); + if not Is_Inline_Floating_Point_Attribute (N) then + Expand_Fpt_Attribute_R (N); + end if; ---------------------- -- Machine_Rounding -- @@ -4037,10 +4339,13 @@ package body Exp_Attr is ----------- -- Transforms 'Model into a call to the floating-point attribute - -- function Model in Fat_xxx (where xxx is the root type) + -- function Model in Fat_xxx (where xxx is the root type). + -- Expansion is avoided for cases the back end can handle directly. when Attribute_Model => - Expand_Fpt_Attribute_R (N); + if not Is_Inline_Floating_Point_Attribute (N) then + Expand_Fpt_Attribute_R (N); + end if; ----------------- -- Object_Size -- @@ -4248,7 +4553,7 @@ package body Exp_Attr is if Restriction_Active (No_Streams) then Rewrite (N, Make_Raise_Program_Error (Sloc (N), - Reason => PE_Explicit_Raise)); + Reason => PE_Stream_Operation_Not_Allowed)); Set_Etype (N, Standard_Void_Type); return; end if; @@ -4554,10 +4859,9 @@ package body Exp_Attr is -- Pred -- ---------- - -- 1. Deal with enumeration types with holes - -- 2. For floating-point, generate call to attribute function and deal - -- with range checking if Check_Float_Overflow mode is set. - -- 3. For other cases, deal with constraint checking + -- 1. Deal with enumeration types with holes. + -- 2. For floating-point, generate call to attribute function. + -- 3. For other cases, deal with constraint checking. when Attribute_Pred => Pred : declare @@ -4629,35 +4933,9 @@ package body Exp_Attr is -- For floating-point, we transform 'Pred into a call to the Pred -- floating-point attribute function in Fat_xxx (xxx is root type). + -- Note that this function takes care of the overflow case. elsif Is_Floating_Point_Type (Ptyp) then - - -- Handle case of range check. The Do_Range_Check flag is set only - -- in Check_Float_Overflow mode, and what we need is a specific - -- check against typ'First, since that is the only overflow case. - - declare - Expr : constant Node_Id := First (Exprs); - begin - if Do_Range_Check (Expr) then - Set_Do_Range_Check (Expr, False); - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Duplicate_Subexpr (Expr), - Right_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_First, - Prefix => - New_Occurrence_Of (Base_Type (Ptyp), Loc))), - Reason => CE_Overflow_Check_Failed), - Suppress => All_Checks); - end if; - end; - - -- Transform into call to attribute function - Expand_Fpt_Attribute_R (N); Analyze_And_Resolve (N, Typ); @@ -4888,7 +5166,7 @@ package body Exp_Attr is if Restriction_Active (No_Streams) then Rewrite (N, Make_Raise_Program_Error (Sloc (N), - Reason => PE_Explicit_Raise)); + Reason => PE_Stream_Operation_Not_Allowed)); Set_Etype (N, B_Type); return; end if; @@ -5113,9 +5391,12 @@ package body Exp_Attr is -- Transforms 'Rounding into a call to the floating-point attribute -- function Rounding in Fat_xxx (where xxx is the root type) + -- Expansion is avoided for cases the back end can handle directly. when Attribute_Rounding => - Expand_Fpt_Attribute_R (N); + if not Is_Inline_Floating_Point_Attribute (N) then + Expand_Fpt_Attribute_R (N); + end if; ------------- -- Scaling -- @@ -5581,9 +5862,9 @@ package body Exp_Attr is -- Succ -- ---------- - -- 1. Deal with enumeration types with holes - -- 2. For floating-point, generate call to attribute function - -- 3. For other cases, deal with constraint checking + -- 1. Deal with enumeration types with holes. + -- 2. For floating-point, generate call to attribute function. + -- 3. For other cases, deal with constraint checking. when Attribute_Succ => Succ : declare Etyp : constant Entity_Id := Base_Type (Ptyp); @@ -5652,33 +5933,6 @@ package body Exp_Attr is -- floating-point attribute function in Fat_xxx (xxx is root type) elsif Is_Floating_Point_Type (Ptyp) then - - -- Handle case of range check. The Do_Range_Check flag is set only - -- in Check_Float_Overflow mode, and what we need is a specific - -- check against typ'Last, since that is the only overflow case. - - declare - Expr : constant Node_Id := First (Exprs); - begin - if Do_Range_Check (Expr) then - Set_Do_Range_Check (Expr, False); - Insert_Action (N, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Duplicate_Subexpr (Expr), - Right_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Last, - Prefix => - New_Occurrence_Of (Base_Type (Ptyp), Loc))), - Reason => CE_Overflow_Check_Failed), - Suppress => All_Checks); - end if; - end; - - -- Transform into call to attribute function - Expand_Fpt_Attribute_R (N); Analyze_And_Resolve (N, Typ); @@ -6010,7 +6264,6 @@ package body Exp_Attr is -- it here. elsif Do_Range_Check (First (Exprs)) then - Set_Do_Range_Check (First (Exprs), False); Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed); end if; end Val; @@ -6096,18 +6349,31 @@ package body Exp_Attr is -- code in the floating-point attribute run-time library. if Is_Floating_Point_Type (Ptyp) then - declare + Float_Valid : declare Pkg : RE_Id; Ftp : Entity_Id; - begin - case Float_Rep (Btyp) is + function Get_Fat_Entity (Nam : Name_Id) return Entity_Id; + -- Return entity for Pkg.Nam - -- For vax fpt types, call appropriate routine in special - -- vax floating point unit. No need to worry about loads in - -- this case, since these types have no signalling NaN's. + -------------------- + -- Get_Fat_Entity -- + -------------------- - when VAX_Native => Expand_Vax_Valid (N); + function Get_Fat_Entity (Nam : Name_Id) return Entity_Id is + Exp_Name : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (RTE (Pkg), Loc), + Selector_Name => Make_Identifier (Loc, Nam)); + begin + Find_Selected_Component (Exp_Name); + return Entity (Exp_Name); + end Get_Fat_Entity; + + -- Start of processing for Float_Valid + + begin + case Float_Rep (Btyp) is -- The AAMP back end handles Valid for floating-point types @@ -6119,34 +6385,83 @@ package body Exp_Attr is when IEEE_Binary => Find_Fat_Info (Ptyp, Ftp, Pkg); - -- If the floating-point object might be unaligned, we - -- need to call the special routine Unaligned_Valid, - -- which makes the needed copy, being careful not to - -- load the value into any floating-point register. - -- The argument in this case is obj'Address (see - -- Unaligned_Valid routine in Fat_Gen). - - if Is_Possibly_Unaligned_Object (Pref) then - Expand_Fpt_Attribute - (N, Pkg, Name_Unaligned_Valid, - New_List ( - Make_Attribute_Reference (Loc, - Prefix => Relocate_Node (Pref), - Attribute_Name => Name_Address))); - - -- In the normal case where we are sure the object is - -- aligned, we generate a call to Valid, and the argument - -- in this case is obj'Unrestricted_Access (after - -- converting obj to the right floating-point type). + -- 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'); - else - Expand_Fpt_Attribute - (N, Pkg, Name_Valid, - New_List ( - Make_Attribute_Reference (Loc, - Prefix => Unchecked_Convert_To (Ftp, Pref), - Attribute_Name => Name_Unrestricted_Access))); + 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 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); + + 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; -- One more task, we still need a range check. Required @@ -6162,10 +6477,10 @@ package body Exp_Attr is Left_Opnd => Relocate_Node (N), Right_Opnd => Make_In (Loc, - Left_Opnd => Convert_To (Btyp, Pref), + Left_Opnd => Convert_To (Btyp, Pref), Right_Opnd => New_Occurrence_Of (Ptyp, Loc)))); end if; - end; + end Float_Valid; -- Enumeration type with holes @@ -6348,21 +6663,25 @@ package body Exp_Attr is Ftyp := Ptyp; end if; + -- Replace by True if no scalar parts + + if not Scalar_Part_Present (Ftyp) then + Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); + -- For scalar types, Valid_Scalars is the same as Valid - if Is_Scalar_Type (Ftyp) then + elsif Is_Scalar_Type (Ftyp) then Rewrite (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Valid, Prefix => Pref)); - Analyze_And_Resolve (N, Standard_Boolean); -- For array types, we construct a function that determines if there -- are any non-valid scalar subcomponents, and call the function. -- We only do this for arrays whose component type needs checking elsif Is_Array_Type (Ftyp) - and then not No_Scalar_Parts (Component_Type (Ftyp)) + and then Scalar_Part_Present (Component_Type (Ftyp)) then Rewrite (N, Make_Function_Call (Loc, @@ -6370,14 +6689,25 @@ package body Exp_Attr is New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc), Parameter_Associations => New_List (Pref))); - Analyze_And_Resolve (N, Standard_Boolean); - - -- For record types, we build a big if expression, applying Valid or - -- Valid_Scalars as appropriate to all relevant components. + -- For record types, we construct a function that determines if there + -- are any non-valid scalar subcomponents, and call the function. - elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp)) - and then not No_Scalar_Parts (Ptyp) + elsif Is_Record_Type (Ftyp) + and then Nkind (Type_Definition (Declaration_Node (Ftyp))) = + N_Record_Definition then + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Build_Record_VS_Func (Ftyp, N), Loc), + Parameter_Associations => New_List (Pref))); + + -- Other record types or types with discriminants + + elsif Is_Record_Type (Ftyp) or else Has_Discriminants (Ptyp) then + + -- Build expression with list of equality tests + declare C : Entity_Id; X : Node_Id; @@ -6387,7 +6717,7 @@ package body Exp_Attr is X := New_Occurrence_Of (Standard_True, Loc); C := First_Component_Or_Discriminant (Ptyp); while Present (C) loop - if No_Scalar_Parts (Etype (C)) then + if not Scalar_Part_Present (Etype (C)) then goto Continue; elsif Is_Scalar_Type (Etype (C)) then A := Name_Valid; @@ -6412,16 +6742,18 @@ package body Exp_Attr is end loop; Rewrite (N, X); - Analyze_And_Resolve (N, Standard_Boolean); end; - -- For all other types, result is True (but not static) + -- For all other types, result is True else Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc)); - Analyze_And_Resolve (N, Standard_Boolean); - Set_Is_Static_Expression (N, False); end if; + + -- Result is always boolean, but never static + + Analyze_And_Resolve (N, Standard_Boolean); + Set_Is_Static_Expression (N, False); end Valid_Scalars; ----------- @@ -6601,7 +6933,7 @@ package body Exp_Attr is if Restriction_Active (No_Streams) then Rewrite (N, Make_Raise_Program_Error (Sloc (N), - Reason => PE_Explicit_Raise)); + Reason => PE_Stream_Operation_Not_Allowed)); Set_Etype (N, U_Type); return; end if; @@ -6754,6 +7086,7 @@ package body Exp_Attr is Attribute_Class | Attribute_Compiler_Version | Attribute_Default_Bit_Order | + Attribute_Default_Scalar_Storage_Order | Attribute_Delta | Attribute_Denorm | Attribute_Digits | @@ -7077,78 +7410,36 @@ package body Exp_Attr is Fat_Type : out Entity_Id; Fat_Pkg : out RE_Id) is - Btyp : constant Entity_Id := Base_Type (T); Rtyp : constant Entity_Id := Root_Type (T); - Digs : constant Nat := UI_To_Int (Digits_Value (Btyp)); begin - -- If the base type is VAX float, then get appropriate VAX float type - - if Vax_Float (Btyp) then - case Digs is - when 6 => - Fat_Type := RTE (RE_Fat_VAX_F); - Fat_Pkg := RE_Attr_VAX_F_Float; - - when 9 => - Fat_Type := RTE (RE_Fat_VAX_D); - Fat_Pkg := RE_Attr_VAX_D_Float; - - when 15 => - Fat_Type := RTE (RE_Fat_VAX_G); - Fat_Pkg := RE_Attr_VAX_G_Float; - - when others => - raise Program_Error; - end case; - - -- If root type is VAX float, this is the case where the library has - -- been recompiled in VAX float mode, and we have an IEEE float type. - -- This is when we use the special IEEE Fat packages. - - elsif Vax_Float (Rtyp) then - case Digs is - when 6 => - Fat_Type := RTE (RE_Fat_IEEE_Short); - Fat_Pkg := RE_Attr_IEEE_Short; - - when 15 => - Fat_Type := RTE (RE_Fat_IEEE_Long); - Fat_Pkg := RE_Attr_IEEE_Long; - - when others => - raise Program_Error; - end case; - - -- If neither the base type nor the root type is VAX_Native then VAX - -- float is out of the picture, and we can just use the root type. + -- All we do is use the root type (historically this dealt with + -- VAX-float .. to be cleaned up further later ???) - else - Fat_Type := Rtyp; + Fat_Type := Rtyp; - if Fat_Type = Standard_Short_Float then - Fat_Pkg := RE_Attr_Short_Float; + if Fat_Type = Standard_Short_Float then + Fat_Pkg := RE_Attr_Short_Float; - elsif Fat_Type = Standard_Float then - Fat_Pkg := RE_Attr_Float; + elsif Fat_Type = Standard_Float then + Fat_Pkg := RE_Attr_Float; - elsif Fat_Type = Standard_Long_Float then - Fat_Pkg := RE_Attr_Long_Float; + elsif Fat_Type = Standard_Long_Float then + Fat_Pkg := RE_Attr_Long_Float; - elsif Fat_Type = Standard_Long_Long_Float then - Fat_Pkg := RE_Attr_Long_Long_Float; + elsif Fat_Type = Standard_Long_Long_Float then + Fat_Pkg := RE_Attr_Long_Long_Float; -- Universal real (which is its own root type) is treated as being -- equivalent to Standard.Long_Long_Float, since it is defined to -- have the same precision as the longest Float type. - elsif Fat_Type = Universal_Real then - Fat_Type := Standard_Long_Long_Float; - Fat_Pkg := RE_Attr_Long_Long_Float; + elsif Fat_Type = Universal_Real then + Fat_Type := Standard_Long_Long_Float; + Fat_Pkg := RE_Attr_Long_Long_Float; - else - raise Program_Error; - end if; + else + raise Program_Error; end if; end Find_Fat_Info; @@ -7679,17 +7970,44 @@ package body Exp_Attr is function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N)); + function Is_GCC_Target return Boolean; + -- Return True if we are using a GCC target/back-end + -- ??? Note: the implementation is kludgy/fragile + + ------------------- + -- Is_GCC_Target -- + ------------------- + + function Is_GCC_Target return Boolean is + begin + return VM_Target = No_VM and then not CodePeer_Mode + and then not AAMP_On_Target; + end Is_GCC_Target; + + -- Start of processing for Exp_Attr + begin - if Nkind (Parent (N)) /= N_Type_Conversion + -- Machine and Model can be expanded by the GCC backend only + + if Id = Attribute_Machine or else Id = Attribute_Model then + return Is_GCC_Target; + + -- Remaining cases handled by all back ends are Rounding and Truncation + -- when appearing as the operand of a conversion to some integer type. + + elsif Nkind (Parent (N)) /= N_Type_Conversion or else not Is_Integer_Type (Etype (Parent (N))) then return False; end if; - -- Should also support 'Machine_Rounding and 'Unbiased_Rounding, but - -- required back end support has not been implemented yet ??? + -- Here we are in the integer conversion context + + -- Very probably we should also recognize the cases of Machine_Rounding + -- and unbiased rounding in this conversion context, but the back end is + -- not yet prepared to handle these cases ??? - return Id = Attribute_Truncation; + return Id = Attribute_Rounding or else Id = Attribute_Truncation; end Is_Inline_Floating_Point_Attribute; end Exp_Attr; diff --git a/main/gcc/ada/exp_ch11.adb b/main/gcc/ada/exp_ch11.adb index 1a27245d09c..aafa2b4fdb6 100644 --- a/main/gcc/ada/exp_ch11.adb +++ b/main/gcc/ada/exp_ch11.adb @@ -24,7 +24,6 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Casing; use Casing; with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; @@ -1685,59 +1684,17 @@ package body Exp_Ch11 is Str := String_From_Name_Buffer; - -- For VMS exceptions, convert the raise into a call to - -- lib$stop so it will be handled by __gnat_error_handler. + -- Convert raise to call to the Raise_Exception routine - if Is_VMS_Exception (Id) then - declare - Excep_Image : String_Id; - Cond : Node_Id; - - begin - if Present (Interface_Name (Id)) then - Excep_Image := Strval (Interface_Name (Id)); - else - Get_Name_String (Chars (Id)); - Set_All_Upper_Case; - Excep_Image := String_From_Name_Buffer; - end if; - - if Exception_Code (Id) /= No_Uint then - Cond := - Make_Integer_Literal (Loc, Exception_Code (Id)); - else - Cond := - Unchecked_Convert_To (Standard_Integer, - Make_Function_Call (Loc, - Name => New_Occurrence_Of - (RTE (RE_Import_Value), Loc), - Parameter_Associations => New_List - (Make_String_Literal (Loc, - Strval => Excep_Image)))); - end if; - - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Lib_Stop), Loc), - Parameter_Associations => New_List (Cond))); - Analyze_And_Resolve (Cond, Standard_Integer); - end; - - -- Not VMS exception case, convert raise to call to the - -- Raise_Exception routine. - - else - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), - Parameter_Associations => New_List ( - Make_Attribute_Reference (Loc, - Prefix => Name (N), - Attribute_Name => Name_Identity), - Make_String_Literal (Loc, - Strval => Str)))); - end if; + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Raise_Exception), Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => Name (N), + Attribute_Name => Name_Identity), + Make_String_Literal (Loc, Strval => Str)))); end; -- Case of no name present (reraise). We rewrite the raise to: @@ -2068,10 +2025,10 @@ package body Exp_Ch11 is function Get_RT_Exception_Entity (R : RT_Exception_Code) return Entity_Id is begin - case R is - when RT_CE_Exceptions => return Standard_Constraint_Error; - when RT_PE_Exceptions => return Standard_Program_Error; - when RT_SE_Exceptions => return Standard_Storage_Error; + case Rkind (R) is + when CE_Reason => return Standard_Constraint_Error; + when PE_Reason => return Standard_Program_Error; + when SE_Reason => return Standard_Storage_Error; end case; end Get_RT_Exception_Entity; @@ -2137,16 +2094,18 @@ package body Exp_Ch11 is Add_Str_To_Name_Buffer ("PE_Misaligned_Address_Value"); when PE_Missing_Return => Add_Str_To_Name_Buffer ("PE_Missing_Return"); + when PE_Non_Transportable_Actual => + Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual"); when PE_Overlaid_Controlled_Object => Add_Str_To_Name_Buffer ("PE_Overlaid_Controlled_Object"); when PE_Potentially_Blocking_Operation => Add_Str_To_Name_Buffer ("PE_Potentially_Blocking_Operation"); + when PE_Stream_Operation_Not_Allowed => + Add_Str_To_Name_Buffer ("PE_Stream_Operation_Not_Allowed"); when PE_Stubbed_Subprogram_Called => Add_Str_To_Name_Buffer ("PE_Stubbed_Subprogram_Called"); when PE_Unchecked_Union_Restriction => Add_Str_To_Name_Buffer ("PE_Unchecked_Union_Restriction"); - when PE_Non_Transportable_Actual => - Add_Str_To_Name_Buffer ("PE_Non_Transportable_Actual"); when SE_Empty_Storage_Pool => Add_Str_To_Name_Buffer ("SE_Empty_Storage_Pool"); @@ -2159,29 +2118,6 @@ package body Exp_Ch11 is end case; end Get_RT_Exception_Name; - ---------------------- - -- Is_Non_Ada_Error -- - ---------------------- - - function Is_Non_Ada_Error (E : Entity_Id) return Boolean is - begin - if not OpenVMS_On_Target then - return False; - end if; - - Get_Name_String (Chars (E)); - - -- Note: it is a little irregular for the body of exp_ch11 to know - -- the details of the encoding scheme for names, but on the other - -- hand, gigi knows them, and this is for gigi's benefit anyway. - - if Name_Buffer (1 .. 30) /= "system__aux_dec__non_ada_error" then - return False; - end if; - - return True; - end Is_Non_Ada_Error; - ---------------------------- -- Warn_If_No_Propagation -- ---------------------------- diff --git a/main/gcc/ada/exp_ch11.ads b/main/gcc/ada/exp_ch11.ads index 5fd123e025f..ab93d5d5bc6 100644 --- a/main/gcc/ada/exp_ch11.ads +++ b/main/gcc/ada/exp_ch11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +83,6 @@ package Exp_Ch11 is -- the Rcheck procedure for Code. The name is appended to Namet.Name_Buffer -- without the __gnat_rcheck_ prefix. - function Is_Non_Ada_Error (E : Entity_Id) return Boolean; - -- This function is provided for Gigi use. It returns True if operating on - -- VMS, and the argument E is the entity for System.Aux_Dec.Non_Ada_Error. - -- This is used to generate the special matching code for this exception. - procedure Possible_Local_Raise (N : Node_Id; E : Entity_Id); -- This procedure is called whenever node N might cause the back end -- to generate a local raise for a local Constraint/Program/Storage_Error diff --git a/main/gcc/ada/exp_ch3.adb b/main/gcc/ada/exp_ch3.adb index 160cfea761f..bd4886da512 100644 --- a/main/gcc/ada/exp_ch3.adb +++ b/main/gcc/ada/exp_ch3.adb @@ -56,6 +56,7 @@ 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; @@ -147,8 +148,8 @@ package body Exp_Ch3 is -- The resulting operation is a TSS subprogram. procedure Build_Variant_Record_Equality (Typ : Entity_Id); - -- Create An Equality function for the non-tagged variant record 'Typ' - -- and attach it to the TSS list + -- Create An Equality function for the untagged variant record Typ and + -- attach it to the TSS list procedure Check_Stream_Attributes (Typ : Entity_Id); -- Check that if a limited extension has a parent with user-defined stream @@ -164,11 +165,6 @@ package body Exp_Ch3 is -- needed after an initialization. Typ is the component type, and Proc_Id -- the initialization procedure for the enclosing composite type. - procedure Expand_Tagged_Root (T : Entity_Id); - -- Add a field _Tag at the beginning of the record. This field carries - -- the value of the access to the Dispatch table. This procedure is only - -- called on root type, the _Tag field being inherited by the descendants. - procedure Expand_Freeze_Array_Type (N : Node_Id); -- Freeze an array type. Deals with building the initialization procedure, -- creating the packed array type for a packed array and also with the @@ -192,6 +188,11 @@ package body Exp_Ch3 is -- applies only to E_Record_Type entities, not to class wide types, -- record subtypes, or private types. + procedure Expand_Tagged_Root (T : Entity_Id); + -- Add a field _Tag at the beginning of the record. This field carries + -- the value of the access to the Dispatch table. This procedure is only + -- called on root type, the _Tag field being inherited by the descendants. + procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id); -- Treat user-defined stream operations as renaming_as_body if the -- subprogram they rename is not frozen when the type is frozen. @@ -241,7 +242,7 @@ package body Exp_Ch3 is CL : Node_Id; Discrs : Elist_Id := New_Elmt_List) return List_Id; -- Building block for variant record equality. Defined to share the code - -- between the tagged and non-tagged case. Given a Component_List node CL, + -- between the tagged and untagged case. Given a Component_List node CL, -- it generates an 'if' followed by a 'case' statement that compares all -- components of local temporaries named X and Y (that are declared as -- formals at some upper level). E provides the Sloc to be used for the @@ -255,7 +256,7 @@ package body Exp_Ch3 is (E : Entity_Id; L : List_Id) return Node_Id; -- Building block for variant record equality. Defined to share the code - -- between the tagged and non-tagged case. Given the list of components + -- between the tagged and untagged case. Given the list of components -- (or discriminants) L, it generates a return statement that compares all -- components of local temporaries named X and Y (that are declared as -- formals at some upper level). E provides the Sloc to be used for the @@ -442,9 +443,7 @@ package body Exp_Ch3 is Ctyp := Etype (Comp); - if not Is_Array_Type (Ctyp) - or else Number_Dimensions (Ctyp) > 1 - then + if not Is_Array_Type (Ctyp) or else Number_Dimensions (Ctyp) > 1 then goto Continue; end if; @@ -633,19 +632,20 @@ package body Exp_Ch3 is return New_List ( Make_Implicit_Loop_Statement (Nod, - Identifier => Empty, + Identifier => Empty, Iteration_Scheme => Make_Iteration_Scheme (Loc, Loop_Parameter_Specification => Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Index, + Defining_Identifier => Index, Discrete_Subtype_Definition => Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uInit), + Prefix => + Make_Identifier (Loc, Name_uInit), Attribute_Name => Name_Range, Expressions => New_List ( Make_Integer_Literal (Loc, N))))), - Statements => Init_One_Dimension (N + 1))); + Statements => Init_One_Dimension (N + 1))); end if; end Init_One_Dimension; @@ -713,9 +713,7 @@ package body Exp_Ch3 is if Has_Default_Init or else (not Restriction_Active (No_Initialize_Scalars) and then Is_Public (A_Type) - and then Root_Type (A_Type) /= Standard_String - and then Root_Type (A_Type) /= Standard_Wide_String - and then Root_Type (A_Type) /= Standard_Wide_Wide_String) + and then not Is_Standard_String_Type (A_Type)) then Proc_Id := Make_Defining_Identifier (Loc, @@ -1492,14 +1490,20 @@ package body Exp_Ch3 is return Empty_List; end if; - -- Go to full view if private type. In the case of successive - -- private derivations, this can require more than one step. + -- Go to full view or underlying full view if private type. In the case + -- of successive private derivations, this can require two steps. - while Is_Private_Type (Full_Type) + if Is_Private_Type (Full_Type) and then Present (Full_View (Full_Type)) - loop + then Full_Type := Full_View (Full_Type); - end loop; + end if; + + if Is_Private_Type (Full_Type) + and then Present (Underlying_Full_View (Full_Type)) + then + Full_Type := Underlying_Full_View (Full_Type); + end if; -- If Typ is derived, the procedure is the initialization procedure for -- the root type. Wrap the argument in an conversion to make it type @@ -1584,12 +1588,6 @@ package body Exp_Ch3 is begin if Is_Protected_Type (T) then T := Corresponding_Record_Type (T); - - elsif Is_Private_Type (T) - and then Present (Underlying_Full_View (T)) - and then Is_Protected_Type (Underlying_Full_View (T)) - then - T := Corresponding_Record_Type (Underlying_Full_View (T)); end if; Arg := @@ -1702,18 +1700,6 @@ package body Exp_Ch3 is end if; end if; - -- When the object is either protected or a task, create static strings - -- which denote the names of entries and families. Associate the strings - -- with the concurrent object's Protection_Entries or ATCB. This is a - -- VMS Debug feature. - - if OpenVMS_On_Target - and then Is_Concurrent_Type (Typ) - and then Entry_Names_OK - then - Build_Entry_Names (Id_Ref, Typ, Res); - end if; - return Res; exception @@ -1753,12 +1739,10 @@ package body Exp_Ch3 is -- objects on list Decls. function Build_Init_Call_Thru (Parameters : List_Id) return List_Id; - -- Given a non-tagged type-derivation that declares discriminants, - -- such as - -- - -- type R (R1, R2 : Integer) is record ... end record; + -- Given an untagged type-derivation that declares discriminants, e.g. -- - -- type D (D1 : Integer) is new R (1, D1); + -- type R (R1, R2 : Integer) is record ... end record; + -- type D (D1 : Integer) is new R (1, D1); -- -- we make the _init_proc of D be -- @@ -2217,7 +2201,6 @@ package body Exp_Ch3 is Body_Node : Node_Id; Body_Stmts : List_Id; Flag_Id : Entity_Id; - Flag_Decl : Node_Id; Handled_Stmt_Node : Node_Id; Init_Tags_List : List_Id; Proc_Id : Entity_Id; @@ -2249,19 +2232,16 @@ package body Exp_Ch3 is Flag_Id := Make_Temporary (Loc, 'F'); - Flag_Decl := + Append_Freeze_Action (Rec_Type, Make_Object_Declaration (Loc, Defining_Identifier => Flag_Id, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => - New_Occurrence_Of (Standard_True, Loc)); - - Analyze (Flag_Decl); - Append_Freeze_Action (Rec_Type, Flag_Decl); + New_Occurrence_Of (Standard_True, Loc))); Body_Stmts := New_List; - Body_Node := New_Node (N_Subprogram_Body, Loc); + Body_Node := New_Node (N_Subprogram_Body, Loc); Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc); @@ -2276,7 +2256,7 @@ package body Exp_Ch3 is Set_Parameter_Specifications (Proc_Spec_Node, New_List); Set_Specification (Body_Node, Proc_Spec_Node); - Set_Declarations (Body_Node, New_List); + Set_Declarations (Body_Node, New_List); Init_Tags_List := Build_Inherit_CPP_Prims (Rec_Type); @@ -2365,8 +2345,7 @@ package body Exp_Ch3 is if not Null_Present (Type_Definition (N)) then Append_List_To (Body_Stmts, - Build_Init_Statements ( - Component_List (Type_Definition (N)))); + Build_Init_Statements (Component_List (Type_Definition (N)))); end if; -- N is a Derived_Type_Definition with a possible non-empty @@ -2596,7 +2575,7 @@ package body Exp_Ch3 is Set_Statements (Handled_Stmt_Node, Body_Stmts); -- Generate: - -- Local_DF_Id (_init, C1, ..., CN); + -- Deep_Finalize (_init, C1, ..., CN); -- raise; if Counter > 0 @@ -2605,30 +2584,36 @@ package body Exp_Ch3 is and then not Restriction_Active (No_Exception_Propagation) then declare - Local_DF_Id : Entity_Id; + DF_Call : Node_Id; + DF_Id : Entity_Id; begin -- Create a local version of Deep_Finalize which has indication -- of partial initialization state. - Local_DF_Id := Make_Temporary (Loc, 'F'); + DF_Id := Make_Temporary (Loc, 'F'); + + Append_To (Decls, Make_Local_Deep_Finalize (Rec_Type, DF_Id)); + + DF_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (DF_Id, Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, Name_uInit), + New_Occurrence_Of (Standard_False, Loc))); + + -- Do not emit warnings related to the elaboration order when a + -- controlled object is declared before the body of Finalize is + -- seen. - Append_To (Decls, - Make_Local_Deep_Finalize (Rec_Type, Local_DF_Id)); + Set_No_Elaboration_Check (DF_Call); Set_Exception_Handlers (Handled_Stmt_Node, New_List ( Make_Exception_Handler (Loc, Exception_Choices => New_List ( Make_Others_Choice (Loc)), - - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Local_DF_Id, Loc), - Parameter_Associations => New_List ( - Make_Identifier (Loc, Name_uInit), - New_Occurrence_Of (Standard_False, Loc))), - + Statements => New_List ( + DF_Call, Make_Raise_Statement (Loc))))); end; else @@ -2812,6 +2797,14 @@ package body Exp_Ch3 is -- Regular component cases else + -- In the context of the init proc, references to discriminants + -- resolve to denote the discriminals: this is where we can + -- freeze discriminant dependent component subtypes. + + if not Is_Frozen (Typ) then + Append_List_To (Stmts, Freeze_Entity (Typ, N)); + end if; + -- Explicit initialization if Present (Expression (Decl)) then @@ -3167,7 +3160,7 @@ package body Exp_Ch3 is exception when RE_Not_Available => - return Empty_List; + return Empty_List; end Build_Init_Statements; ------------------------- @@ -3220,7 +3213,7 @@ package body Exp_Ch3 is begin if Nkind (S) = N_Range then - Process_Range_Expr_In_Decl (S, T, Check_List); + Process_Range_Expr_In_Decl (S, T, Check_List => Check_List); end if; end Constrain_Index; @@ -3692,8 +3685,21 @@ package body Exp_Ch3 is Selector_Name => New_Occurrence_Of (Comp, Loc)); if Is_Access_Type (Typ) then - Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp); - Typ := Designated_Type (Typ); + + -- 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; Call := @@ -3737,7 +3743,15 @@ package body Exp_Ch3 is if Has_Invariants (Etype (Id)) and then In_Open_Scopes (Scope (R_Type)) then - Append_To (Stmts, Build_Component_Invariant_Call (Id)); + 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)) @@ -3810,9 +3824,14 @@ package body Exp_Ch3 is 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), "Invariant")); + Chars => New_External_Name (Chars (R_Type), "CInvariant")); Proc_Body := Make_Subprogram_Body (Loc, @@ -4265,9 +4284,9 @@ package body Exp_Ch3 is end if; end Build_Untagged_Equality; - ------------------------------------ + ----------------------------------- -- Build_Variant_Record_Equality -- - ------------------------------------ + ----------------------------------- -- Generates: @@ -4275,13 +4294,13 @@ package body Exp_Ch3 is -- begin -- -- Compare discriminants - -- if False or else X.D1 /= Y.D1 or else X.D2 /= Y.D2 then + -- if X.D1 /= Y.D1 or else X.D2 /= Y.D2 or else ... then -- return False; -- end if; -- -- Compare components - -- if False or else X.C1 /= Y.C1 or else X.C2 /= Y.C2 then + -- if X.C1 /= Y.C1 or else X.C2 /= Y.C2 or else ... then -- return False; -- end if; @@ -4289,12 +4308,12 @@ package body Exp_Ch3 is -- case X.D1 is -- when V1 => - -- if False or else X.C2 /= Y.C2 or else X.C3 /= Y.C3 then + -- if X.C2 /= Y.C2 or else X.C3 /= Y.C3 or else ... then -- return False; -- end if; -- ... -- when Vn => - -- if False or else X.Cn /= Y.Cn then + -- if X.Cn /= Y.Cn or else ... then -- return False; -- end if; -- end case; @@ -4309,13 +4328,8 @@ package body Exp_Ch3 is Make_Defining_Identifier (Loc, Chars => Make_TSS_Name (Typ, TSS_Composite_Equality)); - X : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_X); - - Y : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_Y); + X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X); + Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y); Def : constant Node_Id := Parent (Typ); Comps : constant Node_Id := Component_List (Type_Definition (Def)); @@ -4343,7 +4357,6 @@ package body Exp_Ch3 is declare Parent_Eq : constant Entity_Id := TSS (Root_Type (Typ), TSS_Composite_Equality); - begin if Present (Parent_Eq) then Copy_TSS (Parent_Eq, Typ); @@ -4440,8 +4453,7 @@ package body Exp_Ch3 is -- the case statement switch. Their value is added when an -- equality call on unchecked unions is expanded. - Append_List_To (Stmts, - Make_Eq_Case (Typ, Comps, New_Discrs)); + Append_List_To (Stmts, Make_Eq_Case (Typ, Comps, New_Discrs)); end; -- Normal case (not unchecked union) @@ -4556,7 +4568,9 @@ package body Exp_Ch3 is begin -- Expand_Record_Extension is called directly from the semantics, so - -- we must check to see whether expansion is active before proceeding + -- we must check to see whether expansion is active before proceeding, + -- because this affects the visibility of selected components in bodies + -- of instances. if not Expander_Active then return; @@ -4645,7 +4659,6 @@ package body Exp_Ch3 is ------------------------------------ procedure Expand_N_Full_Type_Declaration (N : Node_Id) is - procedure Build_Master (Ptr_Typ : Entity_Id); -- Create the master associated with Ptr_Typ @@ -4671,9 +4684,7 @@ package body Exp_Ch3 is -- record parameter for an entry declaration. No master is created -- for such a type. - if Comes_From_Source (N) - and then Has_Task (Desig_Typ) - then + if Comes_From_Source (N) and then Has_Task (Desig_Typ) then Build_Master_Entity (Ptr_Typ); Build_Master_Renaming (Ptr_Typ); @@ -5031,6 +5042,7 @@ package body Exp_Ch3 is -- Local variables + Abrt_Blk : Node_Id; Abrt_HSS : Node_Id; Abrt_Id : Entity_Id; Abrt_Stmts : List_Id; @@ -5041,9 +5053,23 @@ package body Exp_Ch3 is Obj_Init : Node_Id := Empty; Obj_Ref : Node_Id; + Dummy : Entity_Id; + -- This variable captures a dummy internal entity, see the comment + -- associated with its use. + -- Start of processing for Default_Initialize_Object begin + -- Default initialization is suppressed for objects that are already + -- known to be imported (i.e. whose declaration specifies the Import + -- aspect). Note that for objects with a pragma Import, we generate + -- initialization here, and then remove it downstream when processing + -- the pragma. + + if Is_Imported (Def_Id) then + return; + end if; + -- Step 1: Initialize the object if Needs_Finalization (Typ) and then not No_Initialization (N) then @@ -5205,47 +5231,55 @@ package body Exp_Ch3 is -- Step 3b: Build the abort block (if applicable) - -- The abort block is required when aborts are allowed and there is - -- at least one initialization call that needs protection. + -- The abort block is required when aborts are allowed in order to + -- protect both initialization calls. - if Abort_Allowed - and then Present (Comp_Init) - and then Present (Obj_Init) - then - -- Generate: - -- Abort_Defer; + if Present (Comp_Init) and then Present (Obj_Init) then + if Abort_Allowed then - Prepend_To (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); + -- Generate: + -- Abort_Defer; - -- Generate: - -- begin - -- Abort_Defer; - -- - -- at end - -- Abort_Undefer_Direct; - -- end; + Prepend_To + (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); - Abrt_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); - Set_Etype (Abrt_Id, Standard_Void_Type); - Set_Scope (Abrt_Id, Current_Scope); + -- Generate: + -- begin + -- Abort_Defer; + -- + -- at end + -- Abort_Undefer_Direct; + -- end; + + Abrt_HSS := + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Fin_Stmts, + At_End_Proc => + New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); - Abrt_HSS := - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Fin_Stmts, - At_End_Proc => - New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc)); + Abrt_Blk := + Make_Block_Statement (Loc, + Declarations => No_List, + Handled_Statement_Sequence => Abrt_HSS); - Abrt_Stmts := New_List ( - Make_Block_Statement (Loc, - Identifier => New_Occurrence_Of (Abrt_Id, Loc), - Declarations => No_List, - Handled_Statement_Sequence => Abrt_HSS)); + Add_Block_Identifier (Abrt_Blk, Abrt_Id); + Expand_At_End_Handler (Abrt_HSS, Abrt_Id); - Expand_At_End_Handler (Abrt_HSS, Abrt_Id); + Abrt_Stmts := New_List (Abrt_Blk); + + -- Abort is not required + + else + -- Generate a dummy entity to ensure that the internal symbols + -- are in sync when a unit is compiled with and without aborts. + -- The entity is a block with proper scope and type. + + Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); + Set_Etype (Dummy, Standard_Void_Type); + Abrt_Stmts := Fin_Stmts; + end if; - -- Abort is not required, the construct from Step 3a is to be added - -- in the tree (either finalization block or single initialization - -- call). + -- No initialization calls present else Abrt_Stmts := Fin_Stmts; @@ -5271,6 +5305,7 @@ package body Exp_Ch3 is -- Local variables + Next_N : constant Node_Id := Next (N); Id_Ref : Node_Id; New_Ref : Node_Id; @@ -5370,11 +5405,14 @@ package body Exp_Ch3 is -- is raised, then the object will go out of scope. In the case where -- an array object is initialized with an aggregate, the expression -- is removed. Check flag Has_Init_Expression to avoid generating a - -- junk invariant check. + -- junk invariant check and flag No_Initialization to avoid checking + -- an uninitialized object such as a compiler temporary used for an + -- aggregate. if Has_Invariants (Base_Typ) and then Present (Invariant_Procedure (Base_Typ)) and then not Has_Init_Expression (N) + and then not No_Initialization (N) then Insert_After (N, Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc))); @@ -5518,7 +5556,7 @@ package body Exp_Ch3 is -- by -- Tmp : T := Obj; -- type Ityp is not null access I'Class; - -- CW : I'Class renames Ityp(Tmp.I_Tag'Address).all; + -- CW : I'Class renames Ityp (Tmp.I_Tag'Address).all; if Comes_From_Source (Expr_N) and then Nkind (Expr_N) = N_Identifier @@ -5627,7 +5665,8 @@ package body Exp_Ch3 is Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'D'), Subtype_Mark => New_Occurrence_Of (Typ, Loc), - Name => Convert_Tag_To_Interface (Typ, Tag_Comp))); + Name => + Convert_Tag_To_Interface (Typ, Tag_Comp))); -- If the original entity comes from source, then mark the -- new entity as needing debug information, even though it's @@ -5700,8 +5739,7 @@ package body Exp_Ch3 is -- allocated in place, delay checks until assignments are -- made, because the discriminants are not initialized. - if Nkind (Expr) = N_Allocator - and then No_Initialization (Expr) + if Nkind (Expr) = N_Allocator and then No_Initialization (Expr) then null; @@ -5710,13 +5748,18 @@ package body Exp_Ch3 is elsif Nkind (Expr) /= N_Error then Apply_Constraint_Check (Expr, Typ); - -- If the expression has been marked as requiring a range - -- check, generate it now and reset the flag. + -- Deal with possible range check if Do_Range_Check (Expr) then - Set_Do_Range_Check (Expr, False); - if not Suppress_Assignment_Checks (N) then + -- If assignment checks are suppressed, turn off flag + + if Suppress_Assignment_Checks (N) then + Set_Do_Range_Check (Expr, False); + + -- Otherwise generate the range check + + else Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed); end if; @@ -5789,7 +5832,7 @@ package body Exp_Ch3 is -- Handle C++ constructor calls. Note that we do not check that -- Typ is a tagged type since the equivalent Ada type of a C++ - -- class that has no virtual methods is a non-tagged limited + -- class that has no virtual methods is an untagged limited -- record type. elsif Is_CPP_Constructor_Call (Expr) then @@ -5812,9 +5855,14 @@ package body Exp_Ch3 is return; -- For discrete types, set the Is_Known_Valid flag if the - -- initializing value is known to be valid. + -- initializing value is known to be valid. Only do this for + -- source assignments, since otherwise we can end up turning + -- on the known valid flag prematurely from inserted code. - elsif Is_Discrete_Type (Typ) and then Expr_Known_Valid (Expr) then + elsif Comes_From_Source (N) + and then Is_Discrete_Type (Typ) + and then Expr_Known_Valid (Expr) + then Set_Is_Known_Valid (Def_Id); elsif Is_Access_Type (Typ) then @@ -5971,6 +6019,38 @@ package body Exp_Ch3 is end; end if; + -- At this point the object is fully initialized by either invoking the + -- related type init proc, routine [Deep_]Initialize or performing in- + -- place assingments for an array object. If the related type is subject + -- to pragma Default_Initial_Condition, add a runtime check to verify + -- the assumption of the pragma. Generate: + + -- Default_Init_Cond ( (Def_Id)); + + -- Note that the check is generated for source objects only + + if Comes_From_Source (Def_Id) + and then (Has_Default_Init_Cond (Base_Typ) + or else + Has_Inherited_Default_Init_Cond (Base_Typ)) + then + declare + DIC_Call : constant Node_Id := + Build_Default_Init_Cond_Call (Loc, Def_Id, Base_Typ); + begin + if Present (Next_N) then + Insert_Before_And_Analyze (Next_N, DIC_Call); + + -- The object declaration is the last node in a declarative or a + -- statement list. + + else + Append_To (List_Containing (N), DIC_Call); + Analyze (DIC_Call); + end if; + end; + end if; + -- Exception on library entity not available exception @@ -6143,12 +6223,15 @@ package body Exp_Ch3 is -- If the component contains tasks, so does the array type. This may -- not be indicated in the array type because the component may have -- been a private type at the point of definition. Same if component - -- type is controlled. + -- type is controlled or contains protected objects. - Set_Has_Task (Base, Has_Task (Comp_Typ)); - Set_Has_Controlled_Component (Base, - Has_Controlled_Component (Comp_Typ) - or else Is_Controlled (Comp_Typ)); + Set_Has_Task (Base, Has_Task (Comp_Typ)); + Set_Has_Protected (Base, Has_Protected (Comp_Typ)); + Set_Has_Controlled_Component + (Base, Has_Controlled_Component + (Comp_Typ) + or else + Is_Controlled (Comp_Typ)); if No (Init_Proc (Base)) then @@ -6172,10 +6255,7 @@ package body Exp_Ch3 is -- initialize scalars mode, and these types are treated specially -- and do not need initialization procedures. - elsif Root_Type (Base) = Standard_String - or else Root_Type (Base) = Standard_Wide_String - or else Root_Type (Base) = Standard_Wide_Wide_String - then + elsif Is_Standard_String_Type (Base) then null; -- Otherwise we have to build an init proc for the subtype @@ -6702,9 +6782,9 @@ package body Exp_Ch3 is Check_Stream_Attributes (Def_Id); end if; - -- Update task and controlled component flags, because some of the - -- component types may have been private at the point of the record - -- declaration. Detect anonymous access-to-controlled components. + -- Update task, protected, and controlled component flags, because some + -- of the component types may have been private at the point of the + -- record declaration. Detect anonymous access-to-controlled components. Has_AACC := False; @@ -6714,20 +6794,26 @@ package body Exp_Ch3 is if Has_Task (Comp_Typ) then Set_Has_Task (Def_Id); + end if; + + if Has_Protected (Comp_Typ) then + Set_Has_Protected (Def_Id); + end if; -- Do not set Has_Controlled_Component on a class-wide equivalent -- type. See Make_CW_Equivalent_Type. - elsif not Is_Class_Wide_Equivalent_Type (Def_Id) + if not Is_Class_Wide_Equivalent_Type (Def_Id) and then (Has_Controlled_Component (Comp_Typ) or else (Chars (Comp) /= Name_uParent and then Is_Controlled (Comp_Typ))) then Set_Has_Controlled_Component (Def_Id); + end if; -- Non-self-referential anonymous access-to-controlled component - elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type + if Ekind (Comp_Typ) = E_Anonymous_Access_Type and then Needs_Finalization (Designated_Type (Comp_Typ)) and then Designated_Type (Comp_Typ) /= Def_Id then @@ -6737,7 +6823,7 @@ package body Exp_Ch3 is Next_Component (Comp); end loop; - -- Handle constructors of non-tagged CPP_Class types + -- Handle constructors of untagged CPP_Class types if not Is_Tagged_Type (Def_Id) and then Is_CPP_Class (Def_Id) then Set_CPP_Constructors (Def_Id); @@ -6954,7 +7040,7 @@ package body Exp_Ch3 is end if; end if; - -- In the non-tagged case, ever since Ada 83 an equality function must + -- In the untagged case, ever since Ada 83 an equality function must -- be provided for variant records that are not unchecked unions. -- In Ada 2012 the equality function composes, and thus must be built -- explicitly just as for tagged records. @@ -7040,9 +7126,8 @@ package body Exp_Ch3 is -- routine. There is no need to add predefined primitives of interfaces -- because all their predefined primitives are abstract. - if Is_Tagged_Type (Def_Id) - and then not Is_Interface (Def_Id) - then + if Is_Tagged_Type (Def_Id) and then not Is_Interface (Def_Id) then + -- Do not add the body of predefined primitives in case of CPP tagged -- type derivations that have convention CPP. @@ -7145,35 +7230,39 @@ package body Exp_Ch3 is Master_Built := True; -- All anonymous access-to-controlled types allocate - -- on the global pool. + -- 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 (Comp_Typ, - Get_Global_Pool_For_Access_Type (Comp_Typ)); + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); Build_Finalization_Master - (Typ => Comp_Typ, + (Typ => Root_Type (Comp_Typ), Ins_Node => Ins_Node, Encl_Scope => Encl_Scope); Fin_Mas_Id := Finalization_Master (Comp_Typ); -- Subsequent anonymous access-to-controlled components - -- reuse the already available master. + -- reuse the available master. else -- All anonymous access-to-controlled types allocate - -- on the global pool. + -- 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 (Comp_Typ, - Get_Global_Pool_For_Access_Type (Comp_Typ)); + Set_Associated_Storage_Pool + (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object)); -- Shared the master among multiple components - Set_Finalization_Master (Comp_Typ, Fin_Mas_Id); + Set_Finalization_Master + (Root_Type (Comp_Typ), Fin_Mas_Id); -- Convert the master into a heterogeneous collection. -- Generate: - -- -- Set_Is_Heterogeneous (); if not Attributes_Set then @@ -7181,7 +7270,7 @@ package body Exp_Ch3 is Insert_Action (Ins_Node, Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc), Parameter_Associations => New_List ( @@ -7208,8 +7297,20 @@ package body Exp_Ch3 is -- Check whether individual components have a defined invariant, and add -- the corresponding component invariant checks. - Insert_Component_Invariant_Checks - (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N)); + -- 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 (Def_Id) then + Insert_Component_Invariant_Checks + (N, Def_Id, Build_Record_Invariant_Proc (Def_Id, N)); + end if; end Expand_Freeze_Record_Type; ------------------------------ @@ -7228,9 +7329,7 @@ package body Exp_Ch3 is -- Primitive operations of tagged types are frozen when the dispatch -- table is constructed. - if not Comes_From_Source (Typ) - or else Is_Tagged_Type (Typ) - then + if not Comes_From_Source (Typ) or else Is_Tagged_Type (Typ) then return; end if; @@ -7240,7 +7339,7 @@ package body Exp_Ch3 is if Present (Stream_Op) and then Is_Subprogram (Stream_Op) and then Nkind (Unit_Declaration_Node (Stream_Op)) = - N_Subprogram_Declaration + N_Subprogram_Declaration and then not Is_Frozen (Stream_Op) then Append_Freeze_Actions (Typ, Freeze_Entity (Stream_Op, N)); @@ -7269,9 +7368,9 @@ package body Exp_Ch3 is if Present (Access_Types_To_Process (N)) then declare E : Elmt_Id := First_Elmt (Access_Types_To_Process (N)); + begin while Present (E) loop - if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then Validate_RACW_Primitives (Node (E)); RACW_Seen := True; @@ -7281,10 +7380,9 @@ package body Exp_Ch3 is end loop; end; - if RACW_Seen then - - -- If there are RACWs designating this type, make stubs now + -- If there are RACWs designating this type, make stubs now + if RACW_Seen then Remote_Types_Tagged_Full_View_Encountered (Def_Id); end if; end if; @@ -7294,7 +7392,6 @@ package body Exp_Ch3 is if Is_Record_Type (Def_Id) then if Ekind (Def_Id) = E_Record_Type then Expand_Freeze_Record_Type (N); - elsif Is_Class_Wide_Type (Def_Id) then Expand_Freeze_Class_Wide_Type (N); end if; @@ -7359,21 +7456,18 @@ package body Exp_Ch3 is if Is_Composite_Type (Desig_Type) and then not Is_Constrained (Desig_Type) then - DT_Size := - Make_Integer_Literal (Loc, 0); - - DT_Align := - Make_Integer_Literal (Loc, Maximum_Alignment); + DT_Size := Make_Integer_Literal (Loc, 0); + DT_Align := Make_Integer_Literal (Loc, Maximum_Alignment); else DT_Size := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Desig_Type, Loc), + Prefix => New_Occurrence_Of (Desig_Type, Loc), Attribute_Name => Name_Max_Size_In_Storage_Elements); DT_Align := Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Desig_Type, Loc), + Prefix => New_Occurrence_Of (Desig_Type, Loc), Attribute_Name => Name_Alignment); end if; @@ -7407,26 +7501,26 @@ package body Exp_Ch3 is Append_Freeze_Action (Freeze_Action_Typ, Make_Object_Declaration (Loc, Defining_Identifier => Pool_Object, - Object_Definition => + Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (RTE (RE_Stack_Bounded_Pool), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( - -- First discriminant is the Pool Size + -- First discriminant is the Pool Size New_Occurrence_Of ( Storage_Size_Variable (Def_Id), Loc), - -- Second discriminant is the element size + -- Second discriminant is the element size DT_Size, - -- Third discriminant is the alignment + -- Third discriminant is the alignment DT_Align))))); end; @@ -7474,8 +7568,8 @@ package body Exp_Ch3 is if Is_Ancestor (RSPWS, Etype (Pool)) then Error_Msg_N - ("??subpool access type has deeper accessibility " & - "level than pool", Def_Id); + ("??subpool access type has deeper accessibility " + & "level than pool", Def_Id); Append_Freeze_Action (Def_Id, Make_Raise_Program_Error (Loc, @@ -7492,10 +7586,9 @@ package body Exp_Ch3 is elsif Is_Class_Wide_Type (Etype (Pool)) then Append_Freeze_Action (Def_Id, Make_If_Statement (Loc, - Condition => + Condition => Make_In (Loc, - Left_Opnd => - New_Occurrence_Of (Pool, Loc), + Left_Opnd => New_Occurrence_Of (Pool, Loc), Right_Opnd => New_Occurrence_Of (Class_Wide_Type (RSPWS), Loc)), @@ -7885,10 +7978,9 @@ package body Exp_Ch3 is end if; -- The final expression is obtained by doing an unchecked conversion - -- of this result to the base type of the required subtype. We use - -- the base type to prevent the unchecked conversion from chopping - -- bits, and then we set Kill_Range_Check to preserve the "bad" - -- value. + -- of this result to the base type of the required subtype. Use the + -- base type to prevent the unchecked conversion from chopping bits, + -- and then we set Kill_Range_Check to preserve the "bad" value. Result := Unchecked_Convert_To (Base_Type (T), Val); @@ -7904,19 +7996,14 @@ package body Exp_Ch3 is -- String or Wide_[Wide]_String (must have Initialize_Scalars set) - elsif Root_Type (T) = Standard_String - or else - Root_Type (T) = Standard_Wide_String - or else - Root_Type (T) = Standard_Wide_Wide_String - then + elsif Is_Standard_String_Type (T) then pragma Assert (Init_Or_Norm_Scalars); return Make_Aggregate (Loc, Component_Associations => New_List ( Make_Component_Association (Loc, - Choices => New_List ( + Choices => New_List ( Make_Others_Choice (Loc)), Expression => Get_Simple_Init_Val @@ -8007,21 +8094,21 @@ package body Exp_Ch3 is else - -- Find already created invariant body, insert body of component - -- invariant proc in it, and add call after other checks. + -- Find already created invariant subprogram, insert body of + -- component invariant proc in its body, and add call after + -- other checks. declare - Bod : Node_Id; + Bod : Node_Id; Inv_Id : constant Entity_Id := Invariant_Procedure (Typ); - Call : constant Node_Id := - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc_Id, Loc), + 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. @@ -8032,8 +8119,22 @@ package body Exp_Ch3 is 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; @@ -8114,11 +8215,10 @@ package body Exp_Ch3 is Formals := New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_uInit), - In_Present => True, - Out_Present => True, - Parameter_Type => New_Occurrence_Of (Typ, Loc))); + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uInit), + In_Present => True, + Out_Present => True, + Parameter_Type => New_Occurrence_Of (Typ, Loc))); -- For task record value, or type that contains tasks, add two more -- formals, _Master : Master_Id and _Chain : in out Activation_Chain @@ -8209,9 +8309,9 @@ package body Exp_Ch3 is if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then Append_To (Stmts_List, Make_Assignment_Statement (Loc, - Name => + Name => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), + Prefix => New_Copy_Tree (Target), Selector_Name => New_Occurrence_Of (Tag_Comp, Loc)), Expression => New_Occurrence_Of (Iface_Tag, Loc))); @@ -8247,8 +8347,8 @@ package body Exp_Ch3 is Append_To (Stmts_List, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of - (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), + Name => + New_Occurrence_Of (RTE (RE_Set_Dynamic_Offset_To_Top), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Copy_Tree (Target), @@ -8283,11 +8383,12 @@ package body Exp_Ch3 is Append_To (Stmts_List, Make_Assignment_Statement (Loc, - Name => + Name => Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of - (Offset_To_Top_Comp, Loc)), + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Offset_To_Top_Comp, Loc)), + Expression => Make_Attribute_Reference (Loc, Prefix => @@ -8309,7 +8410,7 @@ package body Exp_Ch3 is Offset_Value => Unchecked_Convert_To (RTE (RE_Storage_Offset), Make_Attribute_Reference (Loc, - Prefix => + Prefix => Make_Selected_Component (Loc, Prefix => New_Copy_Tree (Target), Selector_Name => @@ -8328,8 +8429,9 @@ package body Exp_Ch3 is if RTE_Available (RE_Register_Interface_Offset) then Append_To (Stmts_List, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of - (RTE (RE_Register_Interface_Offset), Loc), + Name => + New_Occurrence_Of + (RTE (RE_Register_Interface_Offset), Loc), Parameter_Associations => New_List ( Make_Attribute_Reference (Loc, Prefix => New_Copy_Tree (Target), @@ -8341,14 +8443,13 @@ package body Exp_Ch3 is New_Occurrence_Of (Standard_True, Loc), - Unchecked_Convert_To - (RTE (RE_Storage_Offset), - Make_Attribute_Reference (Loc, - Prefix => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => - New_Occurrence_Of (Tag_Comp, Loc)), + Unchecked_Convert_To (RTE (RE_Storage_Offset), + Make_Attribute_Reference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => + New_Occurrence_Of (Tag_Comp, Loc)), Attribute_Name => Name_Position)), Make_Null (Loc)))); @@ -8422,8 +8523,8 @@ package body Exp_Ch3 is then exit when (Is_Record_Type (Comp_Typ) - and then Is_Variable_Size_Record - (Base_Type (Comp_Typ))) + and then + Is_Variable_Size_Record (Base_Type (Comp_Typ))) or else (Is_Array_Type (Comp_Typ) and then Is_Variable_Size_Array (Comp_Typ)); @@ -8436,7 +8537,7 @@ package body Exp_Ch3 is Error_Msg_Node_2 := Comp; Error_Msg_NE ("parent type & with dynamic component & cannot be parent" - & " of 'C'P'P derivation if new interfaces are present", + & " of 'C'P'P derivation if new interfaces are present", Typ, Scope (Original_Record_Component (Comp))); Error_Msg_Sloc := @@ -8645,16 +8746,17 @@ package body Exp_Ch3 is Make_Simple_Return_Statement (Loc, Expression => Make_Extension_Aggregate (Loc, - Ancestor_Part => + Ancestor_Part => Make_Function_Call (Loc, - Name => New_Occurrence_Of (Alias (Subp), Loc), + Name => + New_Occurrence_Of (Alias (Subp), Loc), Parameter_Associations => Actual_List), Null_Record_Present => True)); Func_Body := Make_Subprogram_Body (Loc, - Specification => New_Copy_Tree (Func_Spec), - Declarations => Empty_List, + Specification => New_Copy_Tree (Func_Spec), + Declarations => Empty_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Return_Stmt))); @@ -8759,6 +8861,7 @@ package body Exp_Ch3 is ------------------ -- + -- case X.D1 is -- when V1 => on subcomponents -- ... @@ -9107,7 +9210,7 @@ package body Exp_Ch3 is Expression => Make_Op_Not (Loc, Make_Function_Call (Loc, - Name => New_Occurrence_Of (Target, Loc), + Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => New_List ( Make_Identifier (Loc, Chars (Left_Op)), Make_Identifier (Loc, Chars (Right_Op))))))); @@ -9171,15 +9274,14 @@ package body Exp_Ch3 is -- of the interface type) if Is_Controlling_Formal (Formal) then - if Nkind (Parameter_Type (Parent (Formal))) - = N_Identifier + if Nkind (Parameter_Type (Parent (Formal))) = N_Identifier then Set_Parameter_Type (New_Param_Spec, New_Occurrence_Of (Tag_Typ, Loc)); else pragma Assert - (Nkind (Parameter_Type (Parent (Formal))) - = N_Access_Definition); + (Nkind (Parameter_Type (Parent (Formal))) = + N_Access_Definition); Set_Subtype_Mark (Parameter_Type (New_Param_Spec), New_Occurrence_Of (Tag_Typ, Loc)); end if; @@ -9194,10 +9296,10 @@ package body Exp_Ch3 is Append_To (Decl_List, Make_Subprogram_Declaration (Loc, Make_Procedure_Specification (Loc, - Defining_Unit_Name => + Defining_Unit_Name => Make_Defining_Identifier (Loc, Chars (Subp)), Parameter_Specifications => Formal_List, - Null_Present => True))); + Null_Present => True))); end if; Next_Elmt (Prim_Elmt); @@ -9236,7 +9338,7 @@ package body Exp_Ch3 is Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : constant List_Id := New_List; - Eq_Name : Name_Id := Name_Op_Eq; + Eq_Name : Name_Id := Name_Op_Eq; Eq_Needed : Boolean; Eq_Spec : Node_Id; Prim : Elmt_Id; @@ -9366,11 +9468,12 @@ package body Exp_Ch3 is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_X), - Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc)), + Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y), - Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), + Parameter_Type => New_Occurrence_Of (Tag_Typ, Loc))), Ret_Type => Standard_Boolean); Append_To (Res, Eq_Spec); @@ -9472,9 +9575,8 @@ package body Exp_Ch3 is Specification => Make_Disp_Timed_Select_Spec (Tag_Typ))); - -- If the ancestor is an interface type we declare non-abstract - -- primitives to override the abstract primitives of the interface - -- type. + -- If ancestor is an interface type, declare non-abstract primitives + -- to override the abstract primitives of the interface type. -- In VM targets we define these primitives in all root tagged types -- that are not interface types. Done because in VM targets we don't @@ -9559,8 +9661,7 @@ package body Exp_Ch3 is Consider_IS : Boolean := True) return Boolean is Consider_IS_NS : constant Boolean := - Normalize_Scalars - or (Initialize_Scalars and Consider_IS); + Normalize_Scalars or (Initialize_Scalars and Consider_IS); begin -- Never need initialization if it is suppressed @@ -9575,7 +9676,6 @@ package body Exp_Ch3 is if Is_Private_Type (T) then declare RT : constant Entity_Id := Underlying_Type (T); - begin if Present (RT) then return Needs_Simple_Initialization (RT); @@ -9604,10 +9704,7 @@ package body Exp_Ch3 is -- filled with appropriate initializing values before they are used). elsif Consider_IS_NS - and then - (Root_Type (T) = Standard_String or else - Root_Type (T) = Standard_Wide_String or else - Root_Type (T) = Standard_Wide_Wide_String) + and then Is_Standard_String_Type (T) and then (not Is_Itype (T) or else Nkind (Associated_Node_For_Itype (T)) /= N_Aggregate) @@ -9898,8 +9995,7 @@ package body Exp_Ch3 is if Stream_Operation_OK (Tag_Typ, TSS_Stream_Output) and then No (TSS (Tag_Typ, TSS_Stream_Output)) then - Build_Record_Or_Elementary_Output_Procedure - (Loc, Tag_Typ, Decl, Ent); + Build_Record_Or_Elementary_Output_Procedure (Loc, Tag_Typ, Decl, Ent); Append_To (Res, Decl); end if; @@ -9947,9 +10043,8 @@ package body Exp_Ch3 is Append_To (Res, Make_Disp_Timed_Select_Body (Tag_Typ)); end if; - if not Is_Limited_Type (Tag_Typ) - and then not Is_Interface (Tag_Typ) - then + if not Is_Limited_Type (Tag_Typ) and then not Is_Interface (Tag_Typ) then + -- Body for equality if Eq_Needed then @@ -10010,6 +10105,7 @@ package body Exp_Ch3 is Make_Adjust_Call ( Obj_Ref => Make_Identifier (Loc, Name_V), Typ => Tag_Typ)))); + else Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, @@ -10029,6 +10125,7 @@ package body Exp_Ch3 is Make_Final_Call (Obj_Ref => Make_Identifier (Loc, Name_V), Typ => Tag_Typ)))); + else Set_Handled_Statement_Sequence (Decl, Make_Handled_Sequence_Of_Statements (Loc, diff --git a/main/gcc/ada/exp_ch4.adb b/main/gcc/ada/exp_ch4.adb index adf8dfce8e6..9068fdcdfbb 100644 --- a/main/gcc/ada/exp_ch4.adb +++ b/main/gcc/ada/exp_ch4.adb @@ -42,7 +42,6 @@ with Exp_Intr; use Exp_Intr; with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Exp_VFpt; use Exp_VFpt; with Freeze; use Freeze; with Inline; use Inline; with Lib; use Lib; @@ -152,11 +151,11 @@ package body Exp_Ch4 is Bodies : List_Id) return Node_Id; -- Local recursive function used to expand equality for nested composite -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which - -- to attach bodies of local functions that are created in the process. - -- It is the responsibility of the caller to insert those bodies at the - -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs - -- are the left and right sides for the comparison, and Typ is the type of - -- the objects to compare. + -- to attach bodies of local functions that are created in the process. It + -- is the responsibility of the caller to insert those bodies at the right + -- place. Nod provides the Sloc value for generated code. Lhs and Rhs are + -- the left and right sides for the comparison, and Typ is the type of the + -- objects to compare. procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id); -- Routine to expand concatenation of a sequence of two or more operands @@ -758,6 +757,24 @@ package body Exp_Ch4 is Obj_Ref := New_Occurrence_Of (Ref, Loc); end if; + -- For access to interface types we must generate code to displace + -- the pointer to the base of the object since the subsequent code + -- references components located in the TSD of the object (which + -- is associated with the primary dispatch table --see a-tags.ads) + -- and also generates code invoking Free, which requires also a + -- reference to the base of the unallocated object. + + if Is_Interface (DesigT) and then Tagged_Type_Expansion then + Obj_Ref := + Unchecked_Convert_To (Etype (Obj_Ref), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Base_Address), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_Address), + New_Copy_Tree (Obj_Ref))))); + end if; + -- Step 1: Create the object clean up code Stmts := New_List; @@ -785,10 +802,10 @@ package body Exp_Ch4 is if Needs_Finalization (DesigT) then Fin_Call := - Make_Final_Call ( - Obj_Ref => - Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), - Typ => DesigT); + Make_Final_Call + (Obj_Ref => + Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), + Typ => DesigT); -- When the target or profile supports deallocation, wrap the -- finalization call in a block to ensure proper deallocation @@ -831,26 +848,13 @@ package body Exp_Ch4 is -- Step 2: Create the accessibility comparison - -- Reference the tag: for a renaming of an access to an interface - -- object Obj_Ref already references the tag of the secondary - -- dispatch table. - - if Nkind (Obj_Ref) in N_Has_Entity - and then Present (Entity (Obj_Ref)) - and then Present (Renamed_Object (Entity (Obj_Ref))) - and then Is_Interface (DesigT) - then - null; - -- Generate: -- Ref'Tag - else - Obj_Ref := - Make_Attribute_Reference (Loc, - Prefix => Obj_Ref, - Attribute_Name => Name_Tag); - end if; + Obj_Ref := + Make_Attribute_Reference (Loc, + Prefix => Obj_Ref, + Attribute_Name => Name_Tag); -- For tagged types, determine the accessibility level by looking -- at the type specific data of the dispatch table. Generate: @@ -1058,9 +1062,9 @@ package body Exp_Ch4 is and then Present (Finalization_Master (PtrT)) then Insert_Action (N, - Make_Attach_Call ( - Obj_Ref => New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); + Make_Attach_Call + (Obj_Ref => New_Occurrence_Of (Temp, Loc), + Ptr_Typ => PtrT)); end if; else @@ -1087,10 +1091,9 @@ package body Exp_Ch4 is and then Present (Finalization_Master (PtrT)) then Insert_Action (N, - Make_Attach_Call ( - Obj_Ref => - New_Occurrence_Of (Temp, Loc), - Ptr_Typ => PtrT)); + Make_Attach_Call + (Obj_Ref => New_Occurrence_Of (Temp, Loc), + Ptr_Typ => PtrT)); end if; end if; @@ -1107,7 +1110,7 @@ package body Exp_Ch4 is New_Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Def_Id, - Type_Definition => + Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, Null_Exclusion_Present => False, @@ -1121,10 +1124,11 @@ package body Exp_Ch4 is -- Inherit the allocation-related attributes from the original -- access type. - Set_Finalization_Master (Def_Id, Finalization_Master (PtrT)); + Set_Finalization_Master + (Def_Id, Finalization_Master (PtrT)); - Set_Associated_Storage_Pool (Def_Id, - Associated_Storage_Pool (PtrT)); + Set_Associated_Storage_Pool + (Def_Id, Associated_Storage_Pool (PtrT)); -- Declare the object using the previous type declaration @@ -1227,9 +1231,9 @@ package body Exp_Ch4 is begin Tag_Assign := Make_Assignment_Statement (Loc, - Name => + Name => Make_Selected_Component (Loc, - Prefix => TagR, + Prefix => TagR, Selector_Name => New_Occurrence_Of (First_Tag_Component (Full_T), Loc)), @@ -1362,9 +1366,8 @@ package body Exp_Ch4 is then -- Apply constraint to designated subtype indication - Apply_Constraint_Check (Expression (Exp), - Designated_Type (DesigT), - No_Sliding => True); + Apply_Constraint_Check + (Expression (Exp), Designated_Type (DesigT), No_Sliding => True); if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then @@ -1386,7 +1389,6 @@ package body Exp_Ch4 is Apply_Constraint_Check (Exp, T, No_Sliding => True); if Do_Range_Check (Exp) then - Set_Do_Range_Check (Exp, False); Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); end if; @@ -1402,7 +1404,6 @@ package body Exp_Ch4 is (Exp, DesigT, No_Sliding => False); if Do_Range_Check (Exp) then - Set_Do_Range_Check (Exp, False); Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed); end if; end if; @@ -1836,9 +1837,9 @@ package body Exp_Ch4 is begin return Make_Attribute_Reference (Loc, - Attribute_Name => Nam, - Prefix => New_Occurrence_Of (Arr, Loc), - Expressions => New_List (Make_Integer_Literal (Loc, Num))); + Attribute_Name => Nam, + Prefix => New_Occurrence_Of (Arr, Loc), + Expressions => New_List (Make_Integer_Literal (Loc, Num))); end Arr_Attr; ------------------------ @@ -1880,7 +1881,7 @@ package body Exp_Ch4 is else return Make_Implicit_If_Statement (Nod, - Condition => Make_Op_Not (Loc, Right_Opnd => Test), + Condition => Make_Op_Not (Loc, Right_Opnd => Test), Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))); @@ -1971,7 +1972,7 @@ package body Exp_Ch4 is Make_Exit_Statement (Loc, Condition => Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (An, Loc), + Left_Opnd => New_Occurrence_Of (An, Loc), Right_Opnd => Arr_Attr (A, Name_Last, N)))); Append_To (Stm_List, @@ -2160,18 +2161,17 @@ package body Exp_Ch4 is Statements => New_List ( Make_Implicit_If_Statement (Nod, - Condition => Test_Empty_Arrays, + Condition => Test_Empty_Arrays, Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_True, Loc)))), Make_Implicit_If_Statement (Nod, - Condition => Test_Lengths_Correspond, + Condition => Test_Lengths_Correspond, Then_Statements => New_List ( Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of (Standard_False, Loc)))), + Expression => New_Occurrence_Of (Standard_False, Loc)))), Handle_One_Dimension (1, First_Index (Ltyp)), @@ -2269,8 +2269,7 @@ package body Exp_Ch4 is elsif Nkind (Parent (N)) = N_Op_Not and then Nkind (N) = N_Op_And - and then - Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) + and then Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) then return; else @@ -2830,11 +2829,20 @@ package body Exp_Ch4 is Rhs_Discr_Val)); end; + -- All cases other than comparing Unchecked_Union types + else - return - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Eq_Op, Loc), - Parameter_Associations => New_List (Lhs, Rhs)); + declare + T : constant Entity_Id := Etype (First_Formal (Eq_Op)); + begin + return + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Eq_Op, Loc), + Parameter_Associations => New_List ( + OK_Convert_To (T, Lhs), + OK_Convert_To (T, Rhs))); + end; end if; end if; @@ -3493,13 +3501,13 @@ package body Exp_Ch4 is -- Low_Bound + Length - 1. High_Bound := - To_Ityp ( - Make_Op_Add (Loc, - Left_Opnd => To_Artyp (New_Copy (Low_Bound)), - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => New_Copy (Aggr_Length (NN)), - Right_Opnd => Make_Artyp_Literal (1)))); + To_Ityp + (Make_Op_Add (Loc, + Left_Opnd => To_Artyp (New_Copy (Low_Bound)), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN)), + Right_Opnd => Make_Artyp_Literal (1)))); -- Note that calculation of the high bound may cause overflow in some -- very weird cases, so in the general case we need an overflow check on @@ -3602,9 +3610,8 @@ package body Exp_Ch4 is if Atyp = Standard_String and then NN in 2 .. 9 and then (Lib_Level_Target - or else - ((Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC) - and then not Debug_Flag_Dot_C)) + or else ((Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC) + and then not Debug_Flag_Dot_C)) then declare RR : constant array (Nat range 2 .. 9) of RE_Id := @@ -3800,7 +3807,7 @@ package body Exp_Ch4 is begin Rewrite (Rop, Make_Range (Loc, - Low_Bound => + Low_Bound => Make_Attribute_Reference (Loc, Attribute_Name => Name_First, Prefix => New_Occurrence_Of (Rtyp, Loc)), @@ -3874,13 +3881,14 @@ package body Exp_Ch4 is Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_And_Then (Loc, - Left_Opnd => + Left_Opnd => Make_Function_Call (Loc, Name => New_Occurrence_Of (RTE (RE_Big_GE), Loc), Parameter_Associations => New_List ( New_Occurrence_Of (L, Loc), Lbound)), + Right_Opnd => Make_Function_Call (Loc, Name => @@ -3979,8 +3987,8 @@ package body Exp_Ch4 is -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last) -- and then T'Base (Lnn) in T; -- end if; - -- - -- SS_Release (M); + + -- SS_Release (M); -- end -- in -- Bnn @@ -4134,12 +4142,14 @@ package body Exp_Ch4 is Convert_To (LLIB, Make_Attribute_Reference (Loc, Attribute_Name => Name_First, - Prefix => New_Occurrence_Of (TB, Loc))), + Prefix => + New_Occurrence_Of (TB, Loc))), High_Bound => Convert_To (LLIB, Make_Attribute_Reference (Loc, Attribute_Name => Name_Last, - Prefix => New_Occurrence_Of (TB, Loc))))), + Prefix => + New_Occurrence_Of (TB, Loc))))), Right_Opnd => Nin)); Set_Analyzed (N, False); Analyze_And_Resolve (N, Restype); @@ -4309,26 +4319,29 @@ package body Exp_Ch4 is -- Anonymous access-to-controlled types allocate on the global pool. -- Do not set this attribute on .NET/JVM since those targets do not - -- support pools. + -- support pools. Note that this is a "root type only" attribute. if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then if Present (Rel_Typ) then - Set_Associated_Storage_Pool (PtrT, - Associated_Storage_Pool (Rel_Typ)); + Set_Associated_Storage_Pool + (Root_Type (PtrT), Associated_Storage_Pool (Rel_Typ)); else - Set_Associated_Storage_Pool (PtrT, - Get_Global_Pool_For_Access_Type (PtrT)); + Set_Associated_Storage_Pool + (Root_Type (PtrT), RTE (RE_Global_Pool_Object)); end if; end if; -- The finalization master must be inserted and analyzed as part of -- the current semantic unit. Note that the master is updated when - -- analysis changes current units. + -- analysis changes current units. Note that this is a "root type + -- only" attribute. if Present (Rel_Typ) then - Set_Finalization_Master (PtrT, Finalization_Master (Rel_Typ)); + Set_Finalization_Master + (Root_Type (PtrT), Finalization_Master (Rel_Typ)); else - Set_Finalization_Master (PtrT, Current_Anonymous_Master); + Set_Finalization_Master + (Root_Type (PtrT), Current_Anonymous_Master); end if; end if; @@ -4528,7 +4541,7 @@ package body Exp_Ch4 is -- type of the access type is a task or contains tasks. In this case -- the call to Init (Temp.all ...) is replaced by code that ensures -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block - -- for details). In addition, if the type T is a task T, then the + -- for details). In addition, if the type T is a task type, then the -- first argument to Init must be converted to the task record type. declare @@ -4991,6 +5004,13 @@ package body Exp_Ch4 is Expression => Expression (N), Alternatives => New_List); + -- Preserve the original context for which the case statement is being + -- generated. This is needed by the finalization machinery to prevent + -- the premature finalization of controlled objects found within the + -- case statement. + + Set_From_Conditional_Expression (Cstmt); + Actions := New_List; -- Scalar case @@ -5247,10 +5267,10 @@ package body Exp_Ch4 is if Compile_Time_Known_Value (Cond) then if Is_True (Expr_Value (Cond)) then - Expr := Thenx; + Expr := Thenx; Actions := Then_Actions (N); else - Expr := Elsex; + Expr := Elsex; Actions := Else_Actions (N); end if; @@ -5273,11 +5293,9 @@ package body Exp_Ch4 is return; end if; - -- If the type is limited or unconstrained, we expand as follows to - -- avoid any possibility of improper copies. - - -- Note: it may be possible to avoid this special processing if the - -- back end uses its own mechanisms for handling by-reference types ??? + -- If the type is limited, and the back end does not handle limited + -- types, then we expand as follows to avoid the possibility of + -- improper copying. -- type Ptr is access all Typ; -- Cnn : Ptr; @@ -5354,9 +5372,48 @@ package body Exp_Ch4 is Prefix => Relocate_Node (Elsex), Attribute_Name => Name_Unrestricted_Access)))); - New_N := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Cnn, Loc)); + -- Preserve the original context for which the if statement is being + -- generated. This is needed by the finalization machinery to prevent + -- the premature finalization of controlled objects found within the + -- if statement. + + Set_From_Conditional_Expression (New_If); + + New_N := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Cnn, Loc)); + + -- If the result is an unconstrained array and the if expression is in a + -- context other than the initializing expression of the declaration of + -- an object, then we pull out the if expression as follows: + + -- Cnn : constant typ := if-expression + + -- and then replace the if expression with an occurrence of Cnn. This + -- avoids the need in the back end to create on-the-fly variable length + -- temporaries (which it cannot do!) + + -- Note that the test for being in an object declaration avoids doing an + -- unnecessary expansion, and also avoids infinite recursion. + + elsif Is_Array_Type (Typ) and then not Is_Constrained (Typ) + and then (Nkind (Parent (N)) /= N_Object_Declaration + or else Expression (Parent (N)) /= N) + then + declare + Cnn : constant Node_Id := Make_Temporary (Loc, 'C', N); + begin + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Cnn, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (N), + Has_Init_Expression => True)); + + Rewrite (N, New_Occurrence_Of (Cnn, Loc)); + return; + end; -- For other types, we only need to expand if there are other actions -- associated with either branch. @@ -5589,7 +5646,7 @@ package body Exp_Ch4 is and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity and then Entity (Prefix (Lo_Orig)) = Ltyp - -- Same tests for right operand + -- Same tests for right operand and then Nkind (Hi_Orig) = N_Attribute_Reference and then Attribute_Name (Hi_Orig) = Name_Last @@ -5894,7 +5951,7 @@ package body Exp_Ch4 is if Is_Acc then Cond := Make_Or_Else (Loc, - Left_Opnd => + Left_Opnd => Make_Op_Eq (Loc, Left_Opnd => Obj, Right_Opnd => Make_Null (Loc)), @@ -5921,7 +5978,7 @@ package body Exp_Ch4 is if Is_Acc then Cond := Make_Or_Else (Loc, - Left_Opnd => + Left_Opnd => Make_Op_Eq (Loc, Left_Opnd => Obj, Right_Opnd => Make_Null (Loc)), @@ -6120,10 +6177,17 @@ package body Exp_Ch4 is -- some problems in handling this peculiar case, for example, the issue -- of dealing specially with object renamings. - if Nkind (P) = N_Slice then + if Nkind (P) = N_Slice + + -- This optimization is disabled for CodePeer because it can transform + -- an index-check constraint_error into a range-check constraint_error + -- and CodePeer cares about that distinction. + + and then not CodePeer_Mode + then Rewrite (N, Make_Indexed_Component (Loc, - Prefix => Prefix (P), + Prefix => Prefix (P), Expressions => New_List ( Convert_To (Etype (First_Index (Etype (P))), @@ -6357,7 +6421,7 @@ package body Exp_Ch4 is procedure Expand_N_Op_Abs (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Expr : constant Node_Id := Right_Opnd (N); + Expr : constant Node_Id := Right_Opnd (N); begin Unary_Op_Validity_Checks (N); @@ -6389,17 +6453,11 @@ package body Exp_Ch4 is Left_Opnd => Duplicate_Subexpr (Expr), Right_Opnd => Make_Attribute_Reference (Loc, - Prefix => + Prefix => New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), Attribute_Name => Name_First)), Reason => CE_Overflow_Check_Failed)); end if; - - -- Vax floating-point types case - - if Vax_Float (Etype (N)) then - Expand_Vax_Arith (N); - end if; end Expand_N_Op_Abs; --------------------- @@ -6441,12 +6499,11 @@ package body Exp_Ch4 is if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then Apply_Arithmetic_Overflow_Check (N); return; + end if; - -- Vax floating-point types case + -- Overflow checks for floating-point if -gnateF mode active - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); - end if; + Check_Float_Op_Overflow (N); end Expand_N_Op_Add; --------------------- @@ -6654,13 +6711,11 @@ package body Exp_Ch4 is elsif Is_Integer_Type (Typ) then Apply_Divide_Checks (N); + end if; - -- Deal with Vax_Float + -- Overflow checks for floating-point if -gnateF mode active - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); - return; - end if; + Check_Float_Op_Overflow (N); end Expand_N_Op_Divide; -------------------- @@ -6694,8 +6749,8 @@ package body Exp_Ch4 is procedure Build_Equality_Call (Eq : Entity_Id) is Op_Type : constant Entity_Id := Etype (First_Formal (Eq)); - L_Exp : Node_Id := Relocate_Node (Lhs); - R_Exp : Node_Id := Relocate_Node (Rhs); + L_Exp : Node_Id := Relocate_Node (Lhs); + R_Exp : Node_Id := Relocate_Node (Rhs); begin -- Adjust operands if necessary to comparison type @@ -6803,10 +6858,10 @@ package body Exp_Ch4 is First_Discriminant (Scope (Entity (Selector_Name (Lhs)))); while Present (Discr) loop - Append_Elmt ( - Make_Identifier (Loc, - Chars => New_External_Name (Chars (Discr), 'A')), - To => Lhs_Discr_Vals); + Append_Elmt + (Make_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'A')), + To => Lhs_Discr_Vals); Next_Discriminant (Discr); end loop; @@ -6816,15 +6871,15 @@ package body Exp_Ch4 is else Discr := First_Discriminant (Lhs_Type); while Present (Discr) loop - Append_Elmt ( - Make_Selected_Component (Loc, - Prefix => Prefix (Lhs), - Selector_Name => - New_Copy - (Get_Discriminant_Value (Discr, - Lhs_Type, - Stored_Constraint (Lhs_Type)))), - To => Lhs_Discr_Vals); + Append_Elmt + (Make_Selected_Component (Loc, + Prefix => Prefix (Lhs), + Selector_Name => + New_Copy + (Get_Discriminant_Value (Discr, + Lhs_Type, + Stored_Constraint (Lhs_Type)))), + To => Lhs_Discr_Vals); Next_Discriminant (Discr); end loop; end if; @@ -6836,12 +6891,12 @@ package body Exp_Ch4 is Discr := First_Discriminant (Lhs_Type); while Present (Discr) loop - Append_Elmt ( - New_Copy - (Get_Discriminant_Value (Discr, + Append_Elmt + (New_Copy + (Get_Discriminant_Value (Discr, Lhs_Type, Stored_Constraint (Lhs_Type))), - To => Lhs_Discr_Vals); + To => Lhs_Discr_Vals); Next_Discriminant (Discr); end loop; end if; @@ -6853,31 +6908,31 @@ package body Exp_Ch4 is Has_Per_Object_Constraint (Entity (Selector_Name (Rhs))) then if Is_Unchecked_Union - (Scope (Entity (Selector_Name (Rhs)))) + (Scope (Entity (Selector_Name (Rhs)))) then Discr := First_Discriminant (Scope (Entity (Selector_Name (Rhs)))); while Present (Discr) loop - Append_Elmt ( - Make_Identifier (Loc, - Chars => New_External_Name (Chars (Discr), 'B')), - To => Rhs_Discr_Vals); + Append_Elmt + (Make_Identifier (Loc, + Chars => New_External_Name (Chars (Discr), 'B')), + To => Rhs_Discr_Vals); Next_Discriminant (Discr); end loop; else Discr := First_Discriminant (Rhs_Type); while Present (Discr) loop - Append_Elmt ( - Make_Selected_Component (Loc, - Prefix => Prefix (Rhs), - Selector_Name => - New_Copy (Get_Discriminant_Value - (Discr, - Rhs_Type, - Stored_Constraint (Rhs_Type)))), - To => Rhs_Discr_Vals); + Append_Elmt + (Make_Selected_Component (Loc, + Prefix => Prefix (Rhs), + Selector_Name => + New_Copy (Get_Discriminant_Value + (Discr, + Rhs_Type, + Stored_Constraint (Rhs_Type)))), + To => Rhs_Discr_Vals); Next_Discriminant (Discr); end loop; end if; @@ -6885,12 +6940,12 @@ package body Exp_Ch4 is else Discr := First_Discriminant (Rhs_Type); while Present (Discr) loop - Append_Elmt ( - New_Copy (Get_Discriminant_Value - (Discr, - Rhs_Type, - Stored_Constraint (Rhs_Type))), - To => Rhs_Discr_Vals); + Append_Elmt + (New_Copy (Get_Discriminant_Value + (Discr, + Rhs_Type, + Stored_Constraint (Rhs_Type))), + To => Rhs_Discr_Vals); Next_Discriminant (Discr); end loop; end if; @@ -7248,15 +7303,15 @@ package body Exp_Ch4 is Op_Name := Node (Prim); -- Find the type's predefined equality or an overriding - -- user- defined equality. The reason for not simply calling + -- user-defined equality. The reason for not simply calling -- Find_Prim_Op here is that there may be a user-defined - -- overloaded equality op that precedes the equality that we want, - -- so we have to explicitly search (e.g., there could be an - -- equality with two different parameter types). + -- overloaded equality op that precedes the equality that we + -- want, so we have to explicitly search (e.g., there could be + -- an equality with two different parameter types). else if Is_Class_Wide_Type (Typl) then - Typl := Root_Type (Typl); + Typl := Find_Specific_Type (Typl); end if; Prim := First_Elmt (Primitive_Operations (Typl)); @@ -7312,12 +7367,25 @@ package body Exp_Ch4 is Make_Raise_Program_Error (Loc, Reason => PE_Unchecked_Union_Restriction)); + -- Emit a warning on source equalities only, otherwise the + -- message may appear out of place due to internal use. The + -- warning is unconditional because it is required by the + -- language. + + if Comes_From_Source (N) then + Error_Msg_N + ("Unchecked_Union discriminants cannot be determined??", + N); + Error_Msg_N + ("\Program_Error will be raised for equality operation??", + N); + end if; + -- Prevent Gigi from generating incorrect code by rewriting -- the equality as a standard False (documented where???). Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); - end if; -- If a type support function is present (for complex cases), use it @@ -7367,13 +7435,6 @@ package body Exp_Ch4 is Rewrite_Comparison (N); - -- If we still have comparison for Vax_Float, process it - - if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Eq; @@ -7615,7 +7676,8 @@ package body Exp_Ch4 is Rewrite (N, Convert_To (Typ, Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_Exp_Modular), Loc), + Name => + New_Occurrence_Of (RTE (RE_Exp_Modular), Loc), Parameter_Associations => New_List ( Convert_To (RTE (RE_Unsigned), Base), Make_Integer_Literal (Loc, Modulus (Rtyp)), @@ -7635,9 +7697,9 @@ package body Exp_Ch4 is Rewrite (N, Convert_To (Typ, Make_Op_And (Loc, - Left_Opnd => + Left_Opnd => Make_Function_Call (Loc, - Name => New_Occurrence_Of (Ent, Loc), + Name => New_Occurrence_Of (Ent, Loc), Parameter_Associations => New_List ( Convert_To (Etype (First_Formal (Ent)), Base), Exp)), @@ -7777,13 +7839,6 @@ package body Exp_Ch4 is Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Ge; @@ -7827,13 +7882,6 @@ package body Exp_Ch4 is Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Gt; @@ -7877,13 +7925,6 @@ package body Exp_Ch4 is Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Le; @@ -7927,13 +7968,6 @@ package body Exp_Ch4 is Rewrite_Comparison (N); - -- If we still have comparison, and Vax_Float type, process it - - if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - Optimize_Length_Comparison (N); end Expand_N_Op_Lt; @@ -7967,11 +8001,6 @@ package body Exp_Ch4 is Right_Opnd => Right_Opnd (N))); Analyze_And_Resolve (N, Typ); - - -- Vax floating-point types case - - elsif Vax_Float (Etype (N)) then - Expand_Vax_Arith (N); end if; end Expand_N_Op_Minus; @@ -8036,7 +8065,7 @@ package body Exp_Ch4 is if (LOK and ROK) and then ((Llo >= 0 and then Rlo >= 0) - or else + or else (Lhi <= 0 and then Rhi <= 0)) then Rewrite (N, @@ -8444,13 +8473,11 @@ package body Exp_Ch4 is elsif Is_Signed_Integer_Type (Etype (N)) then Apply_Arithmetic_Overflow_Check (N); + end if; - -- Deal with VAX float case + -- Overflow checks for floating-point if -gnateF mode active - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); - return; - end if; + Check_Float_Op_Overflow (N); end Expand_N_Op_Multiply; -------------------- @@ -8488,13 +8515,6 @@ package body Exp_Ch4 is Rewrite_Comparison (N); - -- If we still have comparison for Vax_Float, process it - - if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then - Expand_Vax_Comparison (N); - return; - end if; - -- For all cases other than elementary types, we rewrite node as the -- negation of an equality operation, and reanalyze. The equality to be -- used is defined in the same scope and has the same signature. This @@ -8542,17 +8562,18 @@ package body Exp_Ch4 is --------------------- -- If the argument is other than a Boolean array type, there is no special - -- expansion required, except for VMS operations on signed integers. + -- expansion required, except for dealing with validity checks, and non- + -- standard boolean representations. - -- For the packed case, we call the special routine in Exp_Pakd, except - -- that if the component size is greater than one, we use the standard - -- routine generating a gruesome loop (it is so peculiar to have packed - -- arrays with non-standard Boolean representations anyway, so it does not - -- matter that we do not handle this case efficiently). + -- For the packed array case, we call the special routine in Exp_Pakd, + -- except that if the component size is greater than one, we use the + -- standard routine generating a gruesome loop (it is so peculiar to have + -- packed arrays with non-standard Boolean representations anyway, so it + -- does not matter that we do not handle this case efficiently). - -- For the unpacked case (and for the special packed case where we have non - -- standard Booleans, as discussed above), we generate and insert into the - -- tree the following function definition: + -- For the unpacked array case (and for the special packed case where we + -- have non standard Booleans, as discussed above), we generate and insert + -- into the tree the following function definition: -- function Nnnn (A : arr) is -- B : arr; @@ -8592,49 +8613,6 @@ package body Exp_Ch4 is return; end if; - -- For the VMS "not" on signed integer types, use conversion to and from - -- a predefined modular type. - - if Is_VMS_Operator (Entity (N)) then - declare - Rtyp : Entity_Id; - Utyp : Entity_Id; - - begin - -- If this is a derived type, retrieve original VMS type so that - -- the proper sized type is used for intermediate values. - - if Is_Derived_Type (Typ) then - Rtyp := First_Subtype (Etype (Typ)); - else - Rtyp := Typ; - end if; - - -- The proper unsigned type must have a size compatible with the - -- operand, to prevent misalignment. - - if RM_Size (Rtyp) <= 8 then - Utyp := RTE (RE_Unsigned_8); - - elsif RM_Size (Rtyp) <= 16 then - Utyp := RTE (RE_Unsigned_16); - - elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then - Utyp := RTE (RE_Unsigned_32); - - else - Utyp := RTE (RE_Long_Long_Unsigned); - end if; - - Rewrite (N, - Unchecked_Convert_To (Typ, - Make_Op_Not (Loc, - Unchecked_Convert_To (Utyp, Right_Opnd (N))))); - Analyze_And_Resolve (N, Typ); - return; - end; - end if; - -- Only array types need any other processing if not Is_Array_Type (Typ) then @@ -9224,12 +9202,11 @@ package body Exp_Ch4 is if Is_Signed_Integer_Type (Typ) or else Is_Fixed_Point_Type (Typ) then Apply_Arithmetic_Overflow_Check (N); + end if; - -- VAX floating-point types case + -- Overflow checks for floating-point if -gnateF mode active - elsif Vax_Float (Typ) then - Expand_Vax_Arith (N); - end if; + Check_Float_Op_Overflow (N); end Expand_N_Op_Subtract; --------------------- @@ -9636,7 +9613,7 @@ package body Exp_Ch4 is Nkind (Parent (Entity (Dval))) = N_Object_Declaration and then Present (Expression (Parent (Entity (Dval)))) and then not - Is_Static_Expression + Is_OK_Static_Expression (Expression (Parent (Entity (Dval)))) then exit Discr_Loop; @@ -10459,13 +10436,29 @@ package body Exp_Ch4 is -- If the level of the operand type is statically deeper than the -- level of the target type, then force Program_Error. Note that this -- can only occur for cases where the attribute is within the body of - -- an instantiation (otherwise the conversion will already have been - -- rejected as illegal). Note: warnings are issued by the analyzer - -- for the instance cases. + -- an instantiation, otherwise the conversion will already have been + -- rejected as illegal. + + -- Note: warnings are issued by the analyzer for the instance cases elsif In_Instance_Body - and then Type_Access_Level (Operand_Type) > - Type_Access_Level (Target_Type) + + -- The case where the target type is an anonymous access type of + -- a discriminant is excluded, because the level of such a type + -- depends on the context and currently the level returned for such + -- types is zero, resulting in warnings about about check failures + -- in certain legal cases involving class-wide interfaces as the + -- designated type (some cases, such as return statements, are + -- checked at run time, but not clear if these are handled right + -- in general, see 3.10.2(12/2-12.5/3) ???). + + and then + not (Ekind (Target_Type) = E_Anonymous_Access_Type + and then Present (Associated_Node_For_Itype (Target_Type)) + and then Nkind (Associated_Node_For_Itype (Target_Type)) = + N_Discriminant_Specification) + and then + Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then Raise_Accessibility_Error; @@ -10887,69 +10880,80 @@ package body Exp_Ch4 is -- The only remaining step is to generate a range check if we still have -- a type conversion at this stage and Do_Range_Check is set. For now we - -- do this only for conversions of discrete types. + -- do this only for conversions of discrete types and for float-to-float + -- conversions. - if Nkind (N) = N_Type_Conversion - and then Is_Discrete_Type (Etype (N)) - then - declare - Expr : constant Node_Id := Expression (N); - Ftyp : Entity_Id; - Ityp : Entity_Id; + if Nkind (N) = N_Type_Conversion then - begin - if Do_Range_Check (Expr) - and then Is_Discrete_Type (Etype (Expr)) + -- For now we only support floating-point cases where both source + -- and target are floating-point types. Conversions where the source + -- and target involve integer or fixed-point types are still TBD, + -- though not clear whether those can even happen at this point, due + -- to transformations above. ??? + + if Is_Floating_Point_Type (Etype (N)) + and then Is_Floating_Point_Type (Etype (Expression (N))) + then + if Do_Range_Check (Expression (N)) + and then Is_Floating_Point_Type (Target_Type) then - Set_Do_Range_Check (Expr, False); + Generate_Range_Check + (Expression (N), Target_Type, CE_Range_Check_Failed); + end if; - -- Before we do a range check, we have to deal with treating a - -- fixed-point operand as an integer. The way we do this is - -- simply to do an unchecked conversion to an appropriate - -- integer type large enough to hold the result. + -- Discrete-to-discrete conversions - -- This code is not active yet, because we are only dealing - -- with discrete types so far ??? + elsif Is_Discrete_Type (Etype (N)) then + declare + Expr : constant Node_Id := Expression (N); + Ftyp : Entity_Id; + Ityp : Entity_Id; - if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer - and then Treat_Fixed_As_Integer (Expr) + begin + if Do_Range_Check (Expr) + and then Is_Discrete_Type (Etype (Expr)) then - Ftyp := Base_Type (Etype (Expr)); + Set_Do_Range_Check (Expr, False); - if Esize (Ftyp) >= Esize (Standard_Integer) then - Ityp := Standard_Long_Long_Integer; - else - Ityp := Standard_Integer; - end if; + -- Before we do a range check, we have to deal with treating + -- a fixed-point operand as an integer. The way we do this + -- is simply to do an unchecked conversion to an appropriate + -- integer type large enough to hold the result. - Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); - end if; + -- This code is not active yet, because we are only dealing + -- with discrete types so far ??? - -- Reset overflow flag, since the range check will include - -- dealing with possible overflow, and generate the check. If - -- Address is either a source type or target type, suppress - -- range check to avoid typing anomalies when it is a visible - -- integer type. + if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer + and then Treat_Fixed_As_Integer (Expr) + then + Ftyp := Base_Type (Etype (Expr)); - Set_Do_Overflow_Check (N, False); - if not Is_Descendent_Of_Address (Etype (Expr)) - and then not Is_Descendent_Of_Address (Target_Type) - then - Generate_Range_Check - (Expr, Target_Type, CE_Range_Check_Failed); - end if; - end if; - end; - end if; + if Esize (Ftyp) >= Esize (Standard_Integer) then + Ityp := Standard_Long_Long_Integer; + else + Ityp := Standard_Integer; + end if; - -- Final step, if the result is a type conversion involving Vax_Float - -- types, then it is subject for further special processing. + Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); + end if; - if Nkind (N) = N_Type_Conversion - and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type)) - then - Expand_Vax_Conversion (N); - goto Done; + -- Reset overflow flag, since the range check will include + -- dealing with possible overflow, and generate the check. + -- If Address is either a source type or target type, + -- suppress range check to avoid typing anomalies when + -- it is a visible integer type. + + Set_Do_Overflow_Check (N, False); + + if not Is_Descendent_Of_Address (Etype (Expr)) + and then not Is_Descendent_Of_Address (Target_Type) + then + Generate_Range_Check + (Expr, Target_Type, CE_Range_Check_Failed); + end if; + end if; + end; + end if; end if; -- Here at end of processing @@ -11569,11 +11573,12 @@ package body Exp_Ch4 is Pool : constant Entity_Id := Associated_Storage_Pool (Typ); Pnod : constant Node_Id := Parent (N); - Addr : Entity_Id; - Alig : Entity_Id; - Deref : Node_Id; - Size : Entity_Id; - Stmt : Node_Id; + Addr : Entity_Id; + Alig : Entity_Id; + Deref : Node_Id; + Size : Entity_Id; + Size_Bits : Node_Id; + Stmt : Node_Id; -- Start of processing for Insert_Dereference_Action @@ -11624,23 +11629,36 @@ package body Exp_Ch4 is Prefix => Duplicate_Subexpr_Move_Checks (N)); Set_Has_Dereference_Action (Deref); - Size := Make_Temporary (Loc, 'S'); + Size_Bits := + Make_Attribute_Reference (Loc, + Prefix => Deref, + Attribute_Name => Name_Size); + + -- Special case of an unconstrained array: need to add descriptor size + if Is_Array_Type (Desig) + and then not Is_Constrained (First_Subtype (Desig)) + then + Size_Bits := + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (First_Subtype (Desig), Loc), + Attribute_Name => Name_Descriptor_Size), + Right_Opnd => Size_Bits); + end if; + + Size := Make_Temporary (Loc, 'S'); Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Size, - Object_Definition => New_Occurrence_Of (RTE (RE_Storage_Count), Loc), - Expression => Make_Op_Divide (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => Deref, - Attribute_Name => Name_Size), - Right_Opnd => - Make_Integer_Literal (Loc, System_Storage_Unit)))); + Left_Opnd => Size_Bits, + Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); -- Calculate the alignment of the dereferenced object. Generate: -- Alig : constant Storage_Count := .all'Alignment; @@ -11651,7 +11669,6 @@ package body Exp_Ch4 is Set_Has_Dereference_Action (Deref); Alig := Make_Temporary (Loc, 'A'); - Insert_Action (N, Make_Object_Declaration (Loc, Defining_Identifier => Alig, @@ -12602,9 +12619,6 @@ package body Exp_Ch4 is -- If False, call to finalizer includes a test of whether the hook -- pointer is null. - In_Cond_Expr : constant Boolean := - Within_Case_Or_If_Expression (Rel_Node); - begin -- Step 0: determine where to attach finalization actions in the tree @@ -12622,10 +12636,10 @@ package body Exp_Ch4 is -- conditional expression. Finalize_Always := - not (In_Cond_Expr - or else - Nkind_In (Original_Node (Rel_Node), N_Case_Expression, - N_If_Expression)); + not Within_Case_Or_If_Expression (Rel_Node) + and then not Nkind_In + (Original_Node (Rel_Node), N_Case_Expression, + N_If_Expression); declare Loc : constant Source_Ptr := Sloc (Rel_Node); diff --git a/main/gcc/ada/exp_ch5.adb b/main/gcc/ada/exp_ch5.adb index eb621b312d9..b39145c7daa 100644 --- a/main/gcc/ada/exp_ch5.adb +++ b/main/gcc/ada/exp_ch5.adb @@ -28,6 +28,7 @@ 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_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; @@ -58,6 +59,7 @@ with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; +with Uintp; use Uintp; with Validsw; use Validsw; package body Exp_Ch5 is @@ -106,7 +108,7 @@ package body Exp_Ch5 is -- using the standard Insert_Actions mechanism. procedure Expand_Assign_Record (N : Node_Id); - -- N is an assignment of a non-tagged record value. This routine handles + -- N is an assignment of an untagged record value. This routine handles -- the case where the assignment must be made component by component, -- either because the target is not byte aligned, or there is a change -- of representation, or when we have a tagged type with a representation @@ -1734,7 +1736,6 @@ package body Exp_Ch5 is -- First deal with generation of range check if required if Do_Range_Check (Rhs) then - Set_Do_Range_Check (Rhs, False); Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed); end if; @@ -2002,6 +2003,14 @@ package body Exp_Ch5 is if Is_Access_Type (Typ) and then Can_Never_Be_Null (Etype (Lhs)) and then not Can_Never_Be_Null (Etype (Rhs)) + + -- If an actual is an out parameter of a null-excluding access + -- type, there is access check on entry, so we set the flag + -- Suppress_Assignment_Checks on the generated statement to + -- assign the actual to the parameter block, and we do not want + -- to generate an additional check at this point. + + and then not Suppress_Assignment_Checks (N) then Apply_Constraint_Check (Rhs, Etype (Lhs)); end if; @@ -2524,7 +2533,13 @@ package body Exp_Ch5 is if Compile_Time_Known_Value (Expr) then Alt := Find_Static_Alternative (N); - Process_Statements_For_Controlled_Objects (Alt); + -- Do not consider controlled objects found in a case statement which + -- actually models a case expression because their early finalization + -- will affect the result of the expression. + + if not From_Conditional_Expression (N) then + Process_Statements_For_Controlled_Objects (Alt); + end if; -- Move statements from this alternative after the case statement. -- They are already analyzed, so will be skipped by the analyzer. @@ -2603,10 +2618,16 @@ package body Exp_Ch5 is -- effects. Remove_Side_Effects (Expression (N)); - Alt := First (Alternatives (N)); - Process_Statements_For_Controlled_Objects (Alt); + -- Do not consider controlled objects found in a case statement + -- which actually models a case expression because their early + -- finalization will affect the result of the expression. + + if not From_Conditional_Expression (N) then + Process_Statements_For_Controlled_Objects (Alt); + end if; + Insert_List_After (N, Statements (Alt)); -- That leaves the case statement as a shell. The alternative that @@ -2660,13 +2681,23 @@ package body Exp_Ch5 is and then Attribute_Name (Choice) = Name_Range) or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) - or else Nkind (Choice) = N_Subtype_Indication then Cond := Make_In (Loc, Left_Opnd => Expression (N), Right_Opnd => Relocate_Node (Choice)); + -- A subtype indication is not a legal operator in a membership + -- test, so retrieve its range. + + elsif Nkind (Choice) = N_Subtype_Indication then + Cond := + Make_In (Loc, + Left_Opnd => Expression (N), + Right_Opnd => + Relocate_Node + (Range_Expression (Constraint (Choice)))); + -- For any other subexpression "expression = value" else @@ -2694,10 +2725,9 @@ package body Exp_Ch5 is -- compute the contents of the Others_Discrete_Choices which is not -- needed by the back end anyway. - -- The reason we do this is that the back end always needs some - -- default for a switch, so if we have not supplied one in the - -- processing above for validity checking, then we need to supply - -- one here. + -- The reason for this is that the back end always needs some default + -- for a switch, so if we have not supplied one in the processing + -- above for validity checking, then we need to supply one here. if not Others_Present then Others_Node := Make_Others_Choice (Sloc (Last_Alt)); @@ -2711,7 +2741,14 @@ package body Exp_Ch5 is Alt := First_Non_Pragma (Alternatives (N)); while Present (Alt) loop - Process_Statements_For_Controlled_Objects (Alt); + + -- Do not consider controlled objects found in a case statement + -- which actually models a case expression because their early + -- finalization will affect the result of the expression. + + if not From_Conditional_Expression (N) then + Process_Statements_For_Controlled_Objects (Alt); + end if; if Has_SP_Choice (Alt) then Expand_Static_Predicates_In_Choices (Alt); @@ -2782,7 +2819,7 @@ package body Exp_Ch5 is I_Spec : constant Node_Id := Iterator_Specification (Isc); Element : constant Entity_Id := Defining_Identifier (I_Spec); Container : constant Node_Id := Entity (Name (I_Spec)); - Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); + Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); Stats : constant List_Id := Statements (N); Cursor : constant Entity_Id := @@ -2914,7 +2951,13 @@ package body Exp_Ch5 is -- these warnings for expander generated code. begin - Process_Statements_For_Controlled_Objects (N); + -- Do not consider controlled objects found in an if statement which + -- actually models an if expression because their early finalization + -- will affect the result of the expression. + + if not From_Conditional_Expression (N) then + Process_Statements_For_Controlled_Objects (N); + end if; Adjust_Condition (Condition (N)); @@ -3001,7 +3044,14 @@ package body Exp_Ch5 is if Present (Elsif_Parts (N)) then E := First (Elsif_Parts (N)); while Present (E) loop - Process_Statements_For_Controlled_Objects (E); + + -- Do not consider controlled objects found in an if statement + -- which actually models an if expression because their early + -- finalization will affect the result of the expression. + + if not From_Conditional_Expression (N) then + Process_Statements_For_Controlled_Objects (E); + end if; Adjust_Condition (Condition (E)); @@ -3157,8 +3207,9 @@ package body Exp_Ch5 is Id : constant Entity_Id := Defining_Identifier (I_Spec); Loc : constant Source_Ptr := Sloc (N); - Container : constant Node_Id := Name (I_Spec); - Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); + Container : constant Node_Id := Name (I_Spec); + Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); + I_Kind : constant Entity_Kind := Ekind (Id); Cursor : Entity_Id; Iterator : Entity_Id; New_Loop : Node_Id; @@ -3253,17 +3304,90 @@ package body Exp_Ch5 is -- type of the iterator must be obtained from the aspect. if Of_Present (I_Spec) then - declare - Default_Iter : constant Entity_Id := - Entity - (Find_Value_Of_Aspect - (Etype (Container), - Aspect_Default_Iterator)); - + Handle_Of : declare + Default_Iter : Entity_Id; Container_Arg : Node_Id; Ent : Entity_Id; + function Get_Default_Iterator + (T : Entity_Id) return Entity_Id; + -- If the container is a derived type, the aspect holds the + -- parent operation. The required one is a primitive of the + -- derived type and is either inherited or overridden. + + -------------------------- + -- Get_Default_Iterator -- + -------------------------- + + function Get_Default_Iterator + (T : Entity_Id) return Entity_Id + is + Iter : constant Entity_Id := + Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator)); + Prim : Elmt_Id; + Op : Entity_Id; + + begin + Container_Arg := New_Copy_Tree (Container); + + -- A previous version of GNAT allowed indexing aspects to + -- be redefined on derived container types, while the + -- default iterator was inherited from the aprent type. + -- This non-standard extension is preserved temporarily for + -- use by the modelling project under debug flag d.X. + + if Debug_Flag_Dot_XX then + if Base_Type (Etype (Container)) /= + Base_Type (Etype (First_Formal (Iter))) + then + Container_Arg := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (First_Formal (Iter)), Loc), + Expression => Container_Arg); + end if; + + return Iter; + + elsif Is_Derived_Type (T) then + + -- The default iterator must be a primitive operation + -- of the type, at the same dispatch slot position. + + 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) + then + return Op; + end if; + + Next_Elmt (Prim); + end loop; + + -- default iterator must exist. + + pragma Assert (False); + + else -- not a derived type + return Iter; + end if; + end Get_Default_Iterator; + + -- Start of processing for Handle_Of + begin + if Is_Class_Wide_Type (Container_Typ) then + Default_Iter := + Get_Default_Iterator (Etype (Base_Type (Container_Typ))); + + else + Default_Iter := Get_Default_Iterator (Etype (Container)); + end if; + Cursor := Make_Temporary (Loc, 'C'); -- For an container element iterator, the iterator type @@ -3281,24 +3405,7 @@ package body Exp_Ch5 is Pack := Scope (Root_Type (Etype (Iter_Type))); -- Rewrite domain of iteration as a call to the default - -- iterator for the container type. If the container is - -- a derived type and the aspect is inherited, convert - -- container to parent type. The Cursor type is also - -- inherited from the scope of the parent. - - if Base_Type (Etype (Container)) = - Base_Type (Etype (First_Formal (Default_Iter))) - then - Container_Arg := New_Copy_Tree (Container); - - else - Container_Arg := - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (First_Formal (Default_Iter)), Loc), - Expression => New_Copy_Tree (Container)); - end if; + -- iterator for the container type. Rewrite (Name (I_Spec), Make_Function_Call (Loc, @@ -3328,9 +3435,9 @@ package body Exp_Ch5 is Decl := Make_Object_Renaming_Declaration (Loc, Defining_Identifier => Id, - Subtype_Mark => + Subtype_Mark => New_Occurrence_Of (Element_Type, Loc), - Name => + Name => Make_Indexed_Component (Loc, Prefix => Relocate_Node (Container_Arg), Expressions => @@ -3376,7 +3483,7 @@ package body Exp_Ch5 is else Prepend_To (Stats, Decl); end if; - end; + end Handle_Of; -- X in Iterate (S) : type of iterator is type of explicitly -- given Iterate function, and the loop variable is the cursor. @@ -3384,7 +3491,6 @@ package body Exp_Ch5 is else Cursor := Id; - Set_Ekind (Cursor, E_Variable); end if; Iterator := Make_Temporary (Loc, 'I'); @@ -3430,6 +3536,7 @@ package body Exp_Ch5 is Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Cursor, Loc), Expression => Rhs)); + Set_Assignment_OK (Name (Last (Stats))); end; -- Generate: @@ -3495,12 +3602,15 @@ package body Exp_Ch5 is -- The cursor is only modified in expanded code, so it appears -- as unassigned to the warning machinery. We must suppress - -- this spurious warning explicitly. + -- this spurious warning explicitly. The cursor's kind is that of + -- the original loop parameter (it is a constant if the domain of + -- iteration is constant). Set_Warnings_Off (Cursor); Set_Assignment_OK (Decl); Insert_Action (N, Decl); + Set_Ekind (Cursor, I_Kind); end; -- If the range of iteration is given by a function call that @@ -3915,6 +4025,19 @@ package body Exp_Ch5 is and then Present (Iterator_Specification (Scheme)) then Expand_Iterator_Loop (N); + + -- An iterator loop may generate renaming declarations for elements + -- that require debug information. This is the case in particular + -- with element iterators, where debug information must be generated + -- for the temporary that holds the element value. These temporaries + -- are created within a transient block whose local declarations are + -- transferred to the loop, which now has non-trivial local objects. + + if Nkind (N) = N_Loop_Statement + and then Present (Identifier (N)) + then + Qualify_Entity_Names (N); + end if; end if; -- When the iteration scheme mentiones attribute 'Loop_Entry, the loop @@ -3946,7 +4069,7 @@ package body Exp_Ch5 is LPS : constant Node_Id := Loop_Parameter_Specification (Isc); Loop_Id : constant Entity_Id := Defining_Identifier (LPS); Ltype : constant Entity_Id := Etype (Loop_Id); - Stat : constant List_Id := Static_Predicate (Ltype); + Stat : constant List_Id := Static_Discrete_Predicate (Ltype); Stmts : constant List_Id := Statements (N); begin @@ -4029,7 +4152,7 @@ package body Exp_Ch5 is function Hi_Val (N : Node_Id) return Node_Id is begin - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then return New_Copy (N); else pragma Assert (Nkind (N) = N_Range); @@ -4043,7 +4166,7 @@ package body Exp_Ch5 is function Lo_Val (N : Node_Id) return Node_Id is begin - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then return New_Copy (N); else pragma Assert (Nkind (N) = N_Range); diff --git a/main/gcc/ada/exp_ch6.adb b/main/gcc/ada/exp_ch6.adb index 51c49fd689a..97464167129 100644 --- a/main/gcc/ada/exp_ch6.adb +++ b/main/gcc/ada/exp_ch6.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -44,7 +43,6 @@ with Exp_Pakd; use Exp_Pakd; with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; -with Exp_VFpt; use Exp_VFpt; with Fname; use Fname; with Freeze; use Freeze; with Inline; use Inline; @@ -53,7 +51,6 @@ with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; -with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; @@ -61,7 +58,6 @@ 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; @@ -72,7 +68,6 @@ with Sem_Res; use Sem_Res; with Sem_SCIL; use Sem_SCIL; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; -with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -83,10 +78,6 @@ with Validsw; use Validsw; package body Exp_Ch6 is - Inlined_Calls : Elist_Id := No_Elist; - Backend_Calls : Elist_Id := No_Elist; - -- List of frontend inlined calls and inline calls passed to the backend - ----------------------- -- Local Subprograms -- ----------------------- @@ -131,7 +122,8 @@ package body Exp_Ch6 is procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; - Master_Actual : Node_Id); + Master_Actual : Node_Id; + Chain : Node_Id := Empty); -- Ada 2005 (AI-318-02): For a build-in-place call, if the result type -- contains tasks, add two actual parameters: the master, and a pointer to -- the caller's activation chain. Master_Actual is the actual parameter @@ -139,9 +131,11 @@ package body Exp_Ch6 is -- master (_master). The two exceptions are: If the function call is the -- initialization expression for an allocator, we pass the master of the -- access type. If the function call is the initialization expression for a - -- return object, we pass along the master passed in by the caller. The - -- activation chain to pass is always the local one. Note: Master_Actual - -- can be Empty, but only if there are no tasks. + -- return object, we pass along the master passed in by the caller. In most + -- contexts, the activation chain to pass is the local one, which is + -- indicated by No (Chain). However, in an allocator, the caller passes in + -- the activation Chain. Note: Master_Actual can be Empty, but only if + -- there are no tasks. procedure Check_Overriding_Operation (Subp : Entity_Id); -- Subp is a dispatching operation. Check whether it may override an @@ -195,6 +189,9 @@ package body Exp_Ch6 is -- For non-scalar objects that are possibly unaligned, add call by copy -- code (copy in for IN and IN OUT, copy out for OUT and IN OUT). -- + -- For OUT and IN OUT parameters, add predicate checks after the call + -- based on the predicates of the actual type. + -- -- The parameter N is IN OUT because in some cases, the expansion code -- rewrites the call as an expression actions with the call inside. In -- this case N is reset to point to the inside call so that the caller @@ -205,19 +202,6 @@ package body Exp_Ch6 is -- call into a temporary which retrieves the returned object from the -- secondary stack using 'reference. - procedure Expand_Inlined_Call - (N : Node_Id; - Subp : Entity_Id; - Orig_Subp : Entity_Id); - -- If called subprogram can be inlined by the front-end, retrieve the - -- analyzed body, replace formals with actuals and expand call in place. - -- Generate thunks for actuals that are expressions, and insert the - -- corresponding constant declarations before the call. If the original - -- call is to a derived operation, the return type is the one of the - -- derived operation, but the body is that of the original, so return - -- expressions in the body must be converted to the desired type (which - -- is simply not noted in the tree without inline expansion). - procedure Expand_Non_Function_Return (N : Node_Id); -- Called by Expand_N_Simple_Return_Statement in case we're returning from -- a procedure body, entry body, accept statement, or extended return @@ -522,7 +506,8 @@ package body Exp_Ch6 is procedure Add_Task_Actuals_To_Build_In_Place_Call (Function_Call : Node_Id; Function_Id : Entity_Id; - Master_Actual : Node_Id) + Master_Actual : Node_Id; + Chain : Node_Id := Empty) is Loc : constant Source_Ptr := Sloc (Function_Call); Result_Subt : constant Entity_Id := @@ -570,10 +555,20 @@ package body Exp_Ch6 is -- Create the actual which is a pointer to the current activation chain - Chain_Actual := - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_uChain), - Attribute_Name => Name_Unrestricted_Access); + if No (Chain) then + Chain_Actual := + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uChain), + Attribute_Name => Name_Unrestricted_Access); + + -- Allocator case; make a reference to the Chain passed in by the caller + + else + Chain_Actual := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Chain, Loc), + Attribute_Name => Name_Unrestricted_Access); + end if; Analyze_And_Resolve (Chain_Actual, Etype (Chain_Formal)); @@ -1100,19 +1095,18 @@ package body Exp_Ch6 is Init := Empty; Indic := Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (F_Typ, Loc), + Subtype_Mark => New_Occurrence_Of (F_Typ, Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Range (Loc, Low_Bound => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Var, Loc), + Prefix => New_Occurrence_Of (Var, Loc), Attribute_Name => Name_First), High_Bound => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Var, Loc), + Prefix => New_Occurrence_Of (Var, Loc), Attribute_Name => Name_Last))))); else @@ -1738,7 +1732,7 @@ package body Exp_Ch6 is Add_Call_By_Copy_Code; end if; - -- RM 3.2.4 (23/3) : A predicate is checked on in-out and out + -- RM 3.2.4 (23/3): A predicate is checked on in-out and out -- by-reference parameters on exit from the call. If the actual -- is a derived type and the operation is inherited, the body -- of the operation will not contain a call to the predicate @@ -1750,45 +1744,33 @@ package body Exp_Ch6 is -- for subtype conversion on assignment, but we can generate the -- required check now. - -- Note that this is needed only if the subtype of the actual has - -- an explicit predicate aspect, not if it inherits them from a - -- base type or ancestor. The check is also superfluous if the - -- subtype is elaborated before the body of the subprogram, but - -- this is harder to verify, and there may be a redundant check. - -- Note also that Subp may be either a subprogram entity for -- direct calls, or a type entity for indirect calls, which must -- be handled separately because the name does not denote an -- overloadable entity. - -- If the formal is class-wide the corresponding postcondition - -- procedure does not include a predicate call, so it has to be - -- generated explicitly. + declare + Aund : constant Entity_Id := Underlying_Type (E_Actual); + Atyp : Entity_Id; - if not Is_Init_Proc (Subp) - and then (Has_Aspect (E_Actual, Aspect_Predicate) - or else - Has_Aspect (E_Actual, Aspect_Dynamic_Predicate) - or else - Has_Aspect (E_Actual, Aspect_Static_Predicate)) - and then Present (Predicate_Function (E_Actual)) - then - if Is_Entity_Name (Actual) - or else - (Is_Derived_Type (E_Actual) - and then Is_Overloadable (Subp) - and then Is_Inherited_Operation_For_Type (Subp, E_Actual)) - then - Append_To (Post_Call, - Make_Predicate_Check (E_Actual, Actual)); + begin + if No (Aund) then + Atyp := E_Actual; + else + Atyp := Aund; + end if; + + if Has_Predicates (Atyp) + and then Present (Predicate_Function (Atyp)) - elsif Is_Class_Wide_Type (E_Formal) - and then not Is_Class_Wide_Type (E_Actual) + -- Skip predicate checks for special cases + + and then Predicate_Tests_On_Arguments (Subp) then Append_To (Post_Call, - Make_Predicate_Check (E_Actual, Actual)); + Make_Predicate_Check (Atyp, Actual)); end if; - end if; + end; -- Processing for IN parameters @@ -1994,7 +1976,6 @@ package body Exp_Ch6 is -- Rewrite call to predefined operator as operator -- Replace actuals to in-out parameters that are numeric conversions, -- with explicit assignment to temporaries before and after the call. - -- Remove optional actuals if First_Optional_Parameter specified. -- Note that the list of actuals has been filled with default expressions -- during semantic analysis of the call. Only the extra actuals required @@ -2031,7 +2012,7 @@ package body Exp_Ch6 is -- entity and Orig_Subp is the entity of the call node N. function Inherited_From_Formal (S : Entity_Id) return Entity_Id; - -- Within an instance, a type derived from a non-tagged formal derived + -- Within an instance, a type derived from an untagged formal derived -- type inherits from the original parent, not from the actual. The -- current derivation mechanism has the derived type inherit from the -- actual, which is only correct outside of the instance. If the @@ -2106,7 +2087,7 @@ package body Exp_Ch6 is Append_To (Extra_Actuals, Make_Parameter_Association (Loc, - Selector_Name => Make_Identifier (Loc, Chars (EF)), + Selector_Name => New_Occurrence_Of (EF, Loc), Explicit_Actual_Parameter => Expr)); Analyze_And_Resolve (Expr, Etype (EF)); @@ -2128,9 +2109,6 @@ package body Exp_Ch6 is -- then register the enclosing unit of Subp to Inlined_Bodies so that -- the body of Subp can be retrieved and analyzed by the backend. - procedure Register_Backend_Call (N : Node_Id); - -- Append N to the list Backend_Calls - ----------------------- -- Do_Backend_Inline -- ----------------------- @@ -2189,19 +2167,6 @@ package body Exp_Ch6 is end if; end Do_Backend_Inline; - --------------------------- - -- Register_Backend_Call -- - --------------------------- - - procedure Register_Backend_Call (N : Node_Id) is - begin - if Backend_Calls = No_Elist then - Backend_Calls := New_Elmt_List; - end if; - - Append_Elmt (N, To => Backend_Calls); - end Register_Backend_Call; - -- Start of processing for Do_Inline begin @@ -2753,7 +2718,6 @@ package body Exp_Ch6 is if Do_Range_Check (Actual) and then Ekind (Formal) = E_In_Parameter then - Set_Do_Range_Check (Actual, False); Generate_Range_Check (Actual, Etype (Formal), CE_Range_Check_Failed); end if; @@ -3157,18 +3121,6 @@ package body Exp_Ch6 is end if; end if; - -- For Ada 2012, if a parameter is aliased, the actual must be a - -- tagged type or an aliased view of an object. - - if Is_Aliased (Formal) - and then not Is_Aliased_View (Actual) - and then not Is_Tagged_Type (Etype (Formal)) - then - Error_Msg_NE - ("actual for aliased formal& must be aliased object", - Actual, Formal); - end if; - -- For IN OUT and OUT parameters, ensure that subscripts are valid -- since this is a left side reference. We only do this for calls -- from the source program since we assume that compiler generated @@ -3676,7 +3628,6 @@ package body Exp_Ch6 is -- check, then generate it here. if Do_Range_Check (Actual) then - Set_Do_Range_Check (Actual, False); Generate_Range_Check (Actual, Etype (Formal), CE_Range_Check_Failed); end if; @@ -3707,19 +3658,27 @@ package body Exp_Ch6 is Resolve (Actual, Parent_Typ); end if; + -- If there is a change of representation, then generate a + -- warning, and do the change of representation. + + elsif not Same_Representation (Formal_Typ, Parent_Typ) then + Error_Msg_N + ("??change of representation required", Actual); + Convert (Actual, Parent_Typ); + -- For array and record types, the parent formal type and -- derived formal type have different sizes or pragma Pack -- status. elsif ((Is_Array_Type (Formal_Typ) - and then Is_Array_Type (Parent_Typ)) + and then Is_Array_Type (Parent_Typ)) or else (Is_Record_Type (Formal_Typ) - and then Is_Record_Type (Parent_Typ))) + and then Is_Record_Type (Parent_Typ))) and then (Esize (Formal_Typ) /= Esize (Parent_Typ) - or else Has_Pragma_Pack (Formal_Typ) /= - Has_Pragma_Pack (Parent_Typ)) + or else Has_Pragma_Pack (Formal_Typ) /= + Has_Pragma_Pack (Parent_Typ)) then Convert (Actual, Parent_Typ); end if; @@ -3867,9 +3826,14 @@ package body Exp_Ch6 is return; end if; - -- Handle inlining (old semantics) + -- Handle inlining. No action needed if the subprogram is not inlined - if Is_Inlined (Subp) and then not Debug_Flag_Dot_K then + if not Is_Inlined (Subp) then + null; + + -- Handle frontend inlining + + elsif not Back_End_Inlining then Inlined_Subprogram : declare Bod : Node_Id; Must_Inline : Boolean := False; @@ -3955,9 +3919,33 @@ package body Exp_Ch6 is end if; end Inlined_Subprogram; - -- Handle inlining (new semantics) + -- Back end inlining: let the back end handle it + + elsif No (Unit_Declaration_Node (Subp)) + or else Nkind (Unit_Declaration_Node (Subp)) /= + N_Subprogram_Declaration + or else No (Body_To_Inline (Unit_Declaration_Node (Subp))) + then + Add_Inlined_Body (Subp); + Register_Backend_Call (Call_Node); + + -- If the call is to a function in a run-time unit that is marked + -- Inline_Always, we must suppress debugging information on it, + -- so that the code that is eventually inlined will not affect + -- debugging of the user program. + + if Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (Subp)))) + and then In_Extended_Main_Source_Unit (N) + then + Set_Needs_Debug_Info (Subp, False); + end if; + + -- Frontend expansion of supported functions returning unconstrained + -- types and simple renamings inlined by the frontend (see Freeze. + -- Build_Renamed_Entity). - elsif Is_Inlined (Subp) then + else declare Spec : constant Node_Id := Unit_Declaration_Node (Subp); @@ -3973,1422 +3961,148 @@ package body Exp_Ch6 is else Do_Inline_Always (Subp, Orig_Subp); - end if; - - elsif Optimization_Level > 0 then - Do_Inline (Subp, Orig_Subp); - end if; - - -- The call may have been inlined or may have been passed to - -- the backend. No further action needed if it was inlined. - - if Nkind (N) /= N_Function_Call then - return; - end if; - end; - end if; - end if; - - -- Check for protected subprogram. This is either an intra-object call, - -- or a protected function call. Protected procedure calls are rewritten - -- as entry calls and handled accordingly. - - -- In Ada 2005, this may be an indirect call to an access parameter that - -- is an access_to_subprogram. In that case the anonymous type has a - -- scope that is a protected operation, but the call is a regular one. - -- In either case do not expand call if subprogram is eliminated. - - Scop := Scope (Subp); - - if Nkind (Call_Node) /= N_Entry_Call_Statement - and then Is_Protected_Type (Scop) - and then Ekind (Subp) /= E_Subprogram_Type - and then not Is_Eliminated (Subp) - then - -- If the call is an internal one, it is rewritten as a call to the - -- corresponding unprotected subprogram. - - Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); - end if; - - -- Functions returning controlled objects need special attention. If - -- the return type is limited, then the context is initialization and - -- different processing applies. If the call is to a protected function, - -- the expansion above will call Expand_Call recursively. Otherwise the - -- function call is transformed into a temporary which obtains the - -- result from the secondary stack. - - if Needs_Finalization (Etype (Subp)) then - if not Is_Limited_View (Etype (Subp)) - and then - (No (First_Formal (Subp)) - or else - not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) - then - Expand_Ctrl_Function_Call (Call_Node); - - -- Build-in-place function calls which appear in anonymous contexts - -- need a transient scope to ensure the proper finalization of the - -- intermediate result after its use. - - elsif Is_Build_In_Place_Function_Call (Call_Node) - and then - Nkind_In (Parent (Call_Node), N_Attribute_Reference, - N_Function_Call, - N_Indexed_Component, - N_Object_Renaming_Declaration, - N_Procedure_Call_Statement, - N_Selected_Component, - N_Slice) - then - Establish_Transient_Scope (Call_Node, Sec_Stack => True); - end if; - end if; - - -- Test for First_Optional_Parameter, and if so, truncate parameter list - -- if there are optional parameters at the trailing end. - -- Note: we never delete procedures for call via a pointer. - - if (Ekind (Subp) = E_Procedure or else Ekind (Subp) = E_Function) - and then Present (First_Optional_Parameter (Subp)) - then - declare - Last_Keep_Arg : Node_Id; - - begin - -- Last_Keep_Arg will hold the last actual that should be kept. - -- If it remains empty at the end, it means that all parameters - -- are optional. - - Last_Keep_Arg := Empty; - - -- Find first optional parameter, must be present since we checked - -- the validity of the parameter before setting it. - - Formal := First_Formal (Subp); - Actual := First_Actual (Call_Node); - while Formal /= First_Optional_Parameter (Subp) loop - Last_Keep_Arg := Actual; - Next_Formal (Formal); - Next_Actual (Actual); - end loop; - - -- We have Formal and Actual pointing to the first potentially - -- droppable argument. We can drop all the trailing arguments - -- whose actual matches the default. Note that we know that all - -- remaining formals have defaults, because we checked that this - -- requirement was met before setting First_Optional_Parameter. - - -- We use Fully_Conformant_Expressions to check for identity - -- between formals and actuals, which may miss some cases, but - -- on the other hand, this is only an optimization (if we fail - -- to truncate a parameter it does not affect functionality). - -- So if the default is 3 and the actual is 1+2, we consider - -- them unequal, which hardly seems worrisome. - - while Present (Formal) loop - if not Fully_Conformant_Expressions - (Actual, Default_Value (Formal)) - then - Last_Keep_Arg := Actual; - end if; - - Next_Formal (Formal); - Next_Actual (Actual); - end loop; - - -- If no arguments, delete entire list, this is the easy case - - if No (Last_Keep_Arg) then - Set_Parameter_Associations (Call_Node, No_List); - Set_First_Named_Actual (Call_Node, Empty); - - -- Case where at the last retained argument is positional. This - -- is also an easy case, since the retained arguments are already - -- in the right form, and we don't need to worry about the order - -- of arguments that get eliminated. - - elsif Is_List_Member (Last_Keep_Arg) then - while Present (Next (Last_Keep_Arg)) loop - Discard_Node (Remove_Next (Last_Keep_Arg)); - end loop; - - Set_First_Named_Actual (Call_Node, Empty); - - -- This is the annoying case where the last retained argument - -- is a named parameter. Since the original arguments are not - -- in declaration order, we may have to delete some fairly - -- random collection of arguments. - - else - declare - Temp : Node_Id; - Passoc : Node_Id; - - begin - -- First step, remove all the named parameters from the - -- list (they are still chained using First_Named_Actual - -- and Next_Named_Actual, so we have not lost them). - - Temp := First (Parameter_Associations (Call_Node)); - - -- Case of all parameters named, remove them all - - if Nkind (Temp) = N_Parameter_Association then - -- Suppress warnings to avoid warning on possible - -- infinite loop (because Call_Node is not modified). - - pragma Warnings (Off); - while Is_Non_Empty_List - (Parameter_Associations (Call_Node)) - loop - Temp := - Remove_Head (Parameter_Associations (Call_Node)); - end loop; - pragma Warnings (On); - - -- Case of mixed positional/named, remove named parameters - - else - while Nkind (Next (Temp)) /= N_Parameter_Association loop - Next (Temp); - end loop; - - while Present (Next (Temp)) loop - Remove (Next (Temp)); - end loop; - end if; - - -- Now we loop through the named parameters, till we get - -- to the last one to be retained, adding them to the list. - -- Note that the Next_Named_Actual list does not need to be - -- touched since we are only reordering them on the actual - -- parameter association list. - - Passoc := Parent (First_Named_Actual (Call_Node)); - loop - Temp := Relocate_Node (Passoc); - Append_To - (Parameter_Associations (Call_Node), Temp); - exit when - Last_Keep_Arg = Explicit_Actual_Parameter (Passoc); - Passoc := Parent (Next_Named_Actual (Passoc)); - end loop; - - Set_Next_Named_Actual (Temp, Empty); - - loop - Temp := Next_Named_Actual (Passoc); - exit when No (Temp); - Set_Next_Named_Actual - (Passoc, Next_Named_Actual (Parent (Temp))); - end loop; - end; - - end if; - end; - end if; - end Expand_Call; - - ------------------------------- - -- Expand_Ctrl_Function_Call -- - ------------------------------- - - procedure Expand_Ctrl_Function_Call (N : Node_Id) is - function Is_Element_Reference (N : Node_Id) return Boolean; - -- Determine whether node N denotes a reference to an Ada 2012 container - -- element. - - -------------------------- - -- Is_Element_Reference -- - -------------------------- - - function Is_Element_Reference (N : Node_Id) return Boolean is - Ref : constant Node_Id := Original_Node (N); - - begin - -- Analysis marks an element reference by setting the generalized - -- indexing attribute of an indexed component before the component - -- is rewritten into a function call. - - return - Nkind (Ref) = N_Indexed_Component - 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 - -- Optimization, if the returned value (which is on the sec-stack) is - -- returned again, no need to copy/readjust/finalize, we can just pass - -- the value thru (see Expand_N_Simple_Return_Statement), and thus no - -- attachment is needed - - if Nkind (Parent (N)) = N_Simple_Return_Statement then - return; - end if; - - -- Resolution is now finished, make sure we don't start analysis again - -- because of the duplication. - - Set_Analyzed (N); - - -- A function which returns a controlled object uses the secondary - -- stack. Rewrite the call into a temporary which obtains the result of - -- the function using 'reference. - - 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. - -- 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 - and then Within_Case_Or_If_Expression (N) - and then Nkind (N) = N_Explicit_Dereference - then - Set_Is_Processed_Transient (Entity (Prefix (N))); - end if; - end Expand_Ctrl_Function_Call; - - ------------------------- - -- Expand_Inlined_Call -- - ------------------------- - - procedure Expand_Inlined_Call - (N : Node_Id; - Subp : Entity_Id; - Orig_Subp : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Is_Predef : constant Boolean := - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Subp))); - Orig_Bod : constant Node_Id := - Body_To_Inline (Unit_Declaration_Node (Subp)); - - Blk : Node_Id; - Decl : Node_Id; - Decls : constant List_Id := New_List; - Exit_Lab : Entity_Id := Empty; - F : Entity_Id; - A : Node_Id; - Lab_Decl : Node_Id; - Lab_Id : Node_Id; - New_A : Node_Id; - Num_Ret : Int := 0; - Ret_Type : Entity_Id; - - Targ : Node_Id; - -- The target of the call. If context is an assignment statement then - -- this is the left-hand side of the assignment, else it is a temporary - -- to which the return value is assigned prior to rewriting the call. - - Targ1 : Node_Id; - -- A separate target used when the return type is unconstrained - - Temp : Entity_Id; - Temp_Typ : Entity_Id; - - Return_Object : Entity_Id := Empty; - -- Entity in declaration in an extended_return_statement - - Is_Unc : Boolean; - Is_Unc_Decl : Boolean; - -- If the type returned by the function is unconstrained and the call - -- can be inlined, special processing is required. - - 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 - -- declaration). Does nothing if Exit_Lab already set. - - function Process_Formals (N : Node_Id) return Traverse_Result; - -- Replace occurrence of a formal with the corresponding actual, or the - -- thunk generated for it. Replace a return statement with an assignment - -- to the target of the call, with appropriate conversions if needed. - - function Process_Sloc (Nod : Node_Id) return Traverse_Result; - -- If the call being expanded is that of an internal subprogram, set the - -- sloc of the generated block to that of the call itself, so that the - -- expansion is skipped by the "next" command in gdb. - -- Same processing for a subprogram in a predefined file, e.g. - -- Ada.Tags. If Debug_Generated_Code is true, suppress this change to - -- simplify our own development. - - procedure Reset_Dispatching_Calls (N : Node_Id); - -- In subtree N search for occurrences of dispatching calls that use the - -- Ada 2005 Object.Operation notation and the object is a formal of the - -- inlined subprogram. Reset the entity associated with Operation in all - -- the found occurrences. - - procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); - -- If the function body is a single expression, replace call with - -- expression, else insert block appropriately. - - procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); - -- If procedure body has no local variables, inline body without - -- creating block, otherwise rewrite call with block. - - function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; - -- Determine whether a formal parameter is used only once in Orig_Bod - - --------------------- - -- Make_Exit_Label -- - --------------------- - - procedure Make_Exit_Label is - Lab_Ent : Entity_Id; - begin - if No (Exit_Lab) then - Lab_Ent := Make_Temporary (Loc, 'L'); - Lab_Id := New_Occurrence_Of (Lab_Ent, Loc); - Exit_Lab := Make_Label (Loc, Lab_Id); - Lab_Decl := - Make_Implicit_Label_Declaration (Loc, - Defining_Identifier => Lab_Ent, - Label_Construct => Exit_Lab); - end if; - end Make_Exit_Label; - - --------------------- - -- Process_Formals -- - --------------------- - - function Process_Formals (N : Node_Id) return Traverse_Result is - A : Entity_Id; - E : Entity_Id; - Ret : Node_Id; - - begin - if Is_Entity_Name (N) and then Present (Entity (N)) then - E := Entity (N); - - if Is_Formal (E) and then Scope (E) = Subp then - A := Renamed_Object (E); - - -- Rewrite the occurrence of the formal into an occurrence of - -- the actual. Also establish visibility on the proper view of - -- the actual's subtype for the body's context (if the actual's - -- subtype is private at the call point but its full view is - -- visible to the body, then the inlined tree here must be - -- analyzed with the full view). - - if Is_Entity_Name (A) then - Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); - Check_Private_View (N); - - elsif Nkind (A) = N_Defining_Identifier then - Rewrite (N, New_Occurrence_Of (A, Loc)); - Check_Private_View (N); - - -- Numeric literal - - else - Rewrite (N, New_Copy (A)); - end if; - end if; - - return Skip; - - elsif Is_Entity_Name (N) - and then Present (Return_Object) - and then Chars (N) = Chars (Return_Object) - then - -- Occurrence within an extended return statement. The return - -- object is local to the body been inlined, and thus the generic - -- copy is not analyzed yet, so we match by name, and replace it - -- with target of call. - - if Nkind (Targ) = N_Defining_Identifier then - Rewrite (N, New_Occurrence_Of (Targ, Loc)); - else - Rewrite (N, New_Copy_Tree (Targ)); - end if; - - return Skip; - - elsif Nkind (N) = N_Simple_Return_Statement then - if No (Expression (N)) then - Make_Exit_Label; - Rewrite (N, - Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); - - else - if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Parent (N))) = N_Subprogram_Body - then - -- Function body is a single expression. No need for - -- exit label. - - null; - - else - Num_Ret := Num_Ret + 1; - Make_Exit_Label; - end if; - - -- Because of the presence of private types, the views of the - -- expression and the context may be different, so place an - -- unchecked conversion to the context type to avoid spurious - -- 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. - - if Nkind_In (Expression (N), N_Aggregate, - N_Null, - N_Real_Literal, - N_Integer_Literal) - then - Ret := - Make_Qualified_Expression (Sloc (N), - Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), - Expression => Relocate_Node (Expression (N))); - else - Ret := - Unchecked_Convert_To - (Ret_Type, Relocate_Node (Expression (N))); - end if; - - if Nkind (Targ) = N_Defining_Identifier then - Rewrite (N, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Targ, Loc), - Expression => Ret)); - else - Rewrite (N, - Make_Assignment_Statement (Loc, - Name => New_Copy (Targ), - Expression => Ret)); - end if; - - Set_Assignment_OK (Name (N)); - - if Present (Exit_Lab) then - Insert_After (N, - Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); - end if; - end if; - - return OK; - - -- An extended return becomes a block whose first statement is the - -- assignment of the initial expression of the return object to the - -- target of the call itself. - - elsif Nkind (N) = N_Extended_Return_Statement then - declare - Return_Decl : constant Entity_Id := - First (Return_Object_Declarations (N)); - Assign : Node_Id; - - begin - Return_Object := Defining_Identifier (Return_Decl); - - if Present (Expression (Return_Decl)) then - if Nkind (Targ) = N_Defining_Identifier then - Assign := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Targ, Loc), - Expression => Expression (Return_Decl)); - else - Assign := - Make_Assignment_Statement (Loc, - Name => New_Copy (Targ), - Expression => Expression (Return_Decl)); - end if; - - Set_Assignment_OK (Name (Assign)); - - if No (Handled_Statement_Sequence (N)) then - Set_Handled_Statement_Sequence (N, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List)); - end if; - - Prepend (Assign, - Statements (Handled_Statement_Sequence (N))); - end if; - - Rewrite (N, - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Handled_Statement_Sequence (N))); - - return OK; - end; - - -- Remove pragma Unreferenced since it may refer to formals that - -- are not visible in the inlined body, and in any case we will - -- not be posting warnings on the inlined body so it is unneeded. - - elsif Nkind (N) = N_Pragma - and then Pragma_Name (N) = Name_Unreferenced - then - Rewrite (N, Make_Null_Statement (Sloc (N))); - return OK; - - else - return OK; - end if; - end Process_Formals; - - procedure Replace_Formals is new Traverse_Proc (Process_Formals); - - ------------------ - -- Process_Sloc -- - ------------------ - - function Process_Sloc (Nod : Node_Id) return Traverse_Result is - begin - if not Debug_Generated_Code then - Set_Sloc (Nod, Sloc (N)); - Set_Comes_From_Source (Nod, False); - end if; - - return OK; - end Process_Sloc; - - procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); - - ------------------------------ - -- Reset_Dispatching_Calls -- - ------------------------------ - - procedure Reset_Dispatching_Calls (N : Node_Id) is - - function Do_Reset (N : Node_Id) return Traverse_Result; - -- Comment required ??? - - -------------- - -- Do_Reset -- - -------------- - - function Do_Reset (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Procedure_Call_Statement - and then Nkind (Name (N)) = N_Selected_Component - and then Nkind (Prefix (Name (N))) = N_Identifier - and then Is_Formal (Entity (Prefix (Name (N)))) - and then Is_Dispatching_Operation - (Entity (Selector_Name (Name (N)))) - then - Set_Entity (Selector_Name (Name (N)), Empty); - end if; - - return OK; - end Do_Reset; - - function Do_Reset_Calls is new Traverse_Func (Do_Reset); - - -- Local variables - - Dummy : constant Traverse_Result := Do_Reset_Calls (N); - pragma Unreferenced (Dummy); - - -- Start of processing for Reset_Dispatching_Calls - - begin - null; - end Reset_Dispatching_Calls; - - --------------------------- - -- Rewrite_Function_Call -- - --------------------------- - - procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is - HSS : constant Node_Id := Handled_Statement_Sequence (Blk); - Fst : constant Node_Id := First (Statements (HSS)); - - begin - -- Optimize simple case: function body is a single return statement, - -- which has been expanded into an assignment. - - if Is_Empty_List (Declarations (Blk)) - and then Nkind (Fst) = N_Assignment_Statement - and then No (Next (Fst)) - then - -- The function call may have been rewritten as the temporary - -- that holds the result of the call, in which case remove the - -- now useless declaration. - - if Nkind (N) = N_Identifier - and then Nkind (Parent (Entity (N))) = N_Object_Declaration - then - Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); - end if; - - Rewrite (N, Expression (Fst)); - - elsif Nkind (N) = N_Identifier - and then Nkind (Parent (Entity (N))) = N_Object_Declaration - then - -- The block assigns the result of the call to the temporary - - Insert_After (Parent (Entity (N)), Blk); - - -- If the context is an assignment, and the left-hand side is free of - -- side-effects, the replacement is also safe. - -- Can this be generalized further??? - - elsif Nkind (Parent (N)) = N_Assignment_Statement - and then - (Is_Entity_Name (Name (Parent (N))) - or else - (Nkind (Name (Parent (N))) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Name (Parent (N))))) - - or else - (Nkind (Name (Parent (N))) = N_Selected_Component - and then Is_Entity_Name (Prefix (Name (Parent (N)))))) - then - -- Replace assignment with the block - - declare - Original_Assignment : constant Node_Id := Parent (N); - - begin - -- Preserve the original assignment node to keep the complete - -- assignment subtree consistent enough for Analyze_Assignment - -- to proceed (specifically, the original Lhs node must still - -- have an assignment statement as its parent). - - -- We cannot rely on Original_Node to go back from the block - -- node to the assignment node, because the assignment might - -- already be a rewrite substitution. - - Discard_Node (Relocate_Node (Original_Assignment)); - Rewrite (Original_Assignment, Blk); - end; - - elsif Nkind (Parent (N)) = N_Object_Declaration then - - -- A call to a function which returns an unconstrained type - -- found in the expression initializing an object-declaration is - -- expanded into a procedure call which must be added after the - -- object declaration. - - if Is_Unc_Decl and then Debug_Flag_Dot_K then - Insert_Action_After (Parent (N), Blk); - else - Set_Expression (Parent (N), Empty); - Insert_After (Parent (N), Blk); - end if; - - elsif Is_Unc and then not Debug_Flag_Dot_K then - Insert_Before (Parent (N), Blk); - end if; - end Rewrite_Function_Call; - - ---------------------------- - -- Rewrite_Procedure_Call -- - ---------------------------- - - procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is - HSS : constant Node_Id := Handled_Statement_Sequence (Blk); - - begin - -- If there is a transient scope for N, this will be the scope of the - -- actions for N, and the statements in Blk need to be within this - -- scope. For example, they need to have visibility on the constant - -- declarations created for the formals. - - -- If N needs no transient scope, and if there are no declarations in - -- the inlined body, we can do a little optimization and insert the - -- statements for the body directly after N, and rewrite N to a - -- null statement, instead of rewriting N into a full-blown block - -- statement. - - if not Scope_Is_Transient - and then Is_Empty_List (Declarations (Blk)) - then - Insert_List_After (N, Statements (HSS)); - Rewrite (N, Make_Null_Statement (Loc)); - else - Rewrite (N, Blk); - end if; - end Rewrite_Procedure_Call; - - ------------------------- - -- Formal_Is_Used_Once -- - ------------------------- - - function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is - Use_Counter : Int := 0; - - function Count_Uses (N : Node_Id) return Traverse_Result; - -- Traverse the tree and count the uses of the formal parameter. - -- In this case, for optimization purposes, we do not need to - -- continue the traversal once more than one use is encountered. - - ---------------- - -- Count_Uses -- - ---------------- - - function Count_Uses (N : Node_Id) return Traverse_Result is - begin - -- The original node is an identifier - - if Nkind (N) = N_Identifier - and then Present (Entity (N)) - - -- Original node's entity points to the one in the copied body - - and then Nkind (Entity (N)) = N_Identifier - and then Present (Entity (Entity (N))) - - -- The entity of the copied node is the formal parameter - - and then Entity (Entity (N)) = Formal - then - Use_Counter := Use_Counter + 1; - - if Use_Counter > 1 then - - -- Denote more than one use and abandon the traversal - - Use_Counter := 2; - return Abandon; - - end if; - end if; - - return OK; - end Count_Uses; - - procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); - - -- Start of processing for Formal_Is_Used_Once - - begin - Count_Formal_Uses (Orig_Bod); - return Use_Counter = 1; - end Formal_Is_Used_Once; - - -- Start of processing for Expand_Inlined_Call - - begin - -- Initializations for old/new semantics - - if not Debug_Flag_Dot_K then - Is_Unc := Is_Array_Type (Etype (Subp)) - and then not Is_Constrained (Etype (Subp)); - Is_Unc_Decl := False; - else - Is_Unc := Returns_Unconstrained_Type (Subp) - and then Optimization_Level > 0; - Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration - and then Is_Unc; - end if; - - -- Check for an illegal attempt to inline a recursive procedure. If the - -- subprogram has parameters this is detected when trying to supply a - -- binding for parameters that already have one. For parameterless - -- subprograms this must be done explicitly. - - if In_Open_Scopes (Subp) then - Error_Msg_N ("call to recursive subprogram cannot be inlined??", N); - Set_Is_Inlined (Subp, False); - return; - - -- Skip inlining if this is not a true inlining since the attribute - -- Body_To_Inline is also set for renamings (see sinfo.ads) - - elsif Nkind (Orig_Bod) in N_Entity then - return; - - -- Skip inlining if the function returns an unconstrained type using - -- an extended return statement since this part of the new inlining - -- model which is not yet supported by the current implementation. ??? - - elsif Is_Unc - and then - Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) - = N_Extended_Return_Statement - and then not Debug_Flag_Dot_K - then - return; - end if; - - if Nkind (Orig_Bod) = N_Defining_Identifier - or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol - then - -- Subprogram is renaming_as_body. Calls occurring after the renaming - -- can be replaced with calls to the renamed entity directly, because - -- the subprograms are subtype conformant. If the renamed subprogram - -- is an inherited operation, we must redo the expansion because - -- implicit conversions may be needed. Similarly, if the renamed - -- entity is inlined, expand the call for further optimizations. - - Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); - - if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then - Expand_Call (N); - end if; - - return; - end if; - - -- Register the call in the list of inlined calls - - if Inlined_Calls = No_Elist then - Inlined_Calls := New_Elmt_List; - end if; - - Append_Elmt (N, To => Inlined_Calls); - - -- Use generic machinery to copy body of inlined subprogram, as if it - -- were an instantiation, resetting source locations appropriately, so - -- that nested inlined calls appear in the main unit. - - Save_Env (Subp, Empty); - Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); - - -- Old semantics - - if not Debug_Flag_Dot_K then - declare - Bod : Node_Id; - - begin - Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); - Blk := - Make_Block_Statement (Loc, - Declarations => Declarations (Bod), - Handled_Statement_Sequence => - Handled_Statement_Sequence (Bod)); - - if No (Declarations (Bod)) then - Set_Declarations (Blk, New_List); - 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 - -- on local variables. Otherwise there is no way to declare the - -- result outside of the block. Needless to say, in general the - -- bounds will depend on the actuals in the call. - - -- If the context is an assignment statement, as is the case - -- for the expansion of an extended return, the left-hand side - -- provides bounds even if the return type is unconstrained. - - if Is_Unc then - declare - First_Decl : Node_Id; - - begin - First_Decl := First (Declarations (Blk)); - - if Nkind (First_Decl) /= N_Object_Declaration then - return; - end if; - - if Nkind (Parent (N)) /= N_Assignment_Statement then - Targ1 := Defining_Identifier (First_Decl); - else - Targ1 := Name (Parent (N)); - end if; - end; - end if; - end; - - -- New semantics - - else - declare - Bod : Node_Id; - - begin - -- General case - - if not Is_Unc then - Bod := - Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); - Blk := - Make_Block_Statement (Loc, - Declarations => Declarations (Bod), - Handled_Statement_Sequence => - Handled_Statement_Sequence (Bod)); - - -- Inline a call to a function that returns an unconstrained type. - -- The semantic analyzer checked that frontend-inlined functions - -- returning unconstrained types have no declarations and have - -- a single extended return statement. As part of its processing - -- the function was split in two subprograms: a procedure P and - -- a function F that has a block with a call to procedure P (see - -- Split_Unconstrained_Function). - - else - pragma Assert - (Nkind - (First - (Statements (Handled_Statement_Sequence (Orig_Bod)))) - = N_Block_Statement); - - declare - Blk_Stmt : constant Node_Id := - First - (Statements - (Handled_Statement_Sequence (Orig_Bod))); - First_Stmt : constant Node_Id := - First - (Statements - (Handled_Statement_Sequence (Blk_Stmt))); - Second_Stmt : constant Node_Id := Next (First_Stmt); - - begin - pragma Assert - (Nkind (First_Stmt) = N_Procedure_Call_Statement - and then Nkind (Second_Stmt) = N_Simple_Return_Statement - and then No (Next (Second_Stmt))); - - Bod := - Copy_Generic_Node - (First - (Statements (Handled_Statement_Sequence (Orig_Bod))), - Empty, Instantiating => True); - Blk := Bod; - - -- 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 on local variables. - -- Otherwise there is no way to declare the result outside - -- of the block. Needless to say, in general the bounds will - -- depend on the actuals in the call. - - if Nkind (Parent (N)) /= N_Assignment_Statement then - Targ1 := Defining_Identifier (First (Declarations (Blk))); - - -- If the context is an assignment statement, as is the case - -- for the expansion of an extended return, the left-hand - -- side provides bounds even if the return type is - -- unconstrained. - - else - Targ1 := Name (Parent (N)); - end if; - end; - end if; - - if No (Declarations (Bod)) then - Set_Declarations (Blk, New_List); - end if; - end; - end if; - - -- If this is a derived function, establish the proper return type - - if Present (Orig_Subp) and then Orig_Subp /= Subp then - Ret_Type := Etype (Orig_Subp); - else - Ret_Type := Etype (Subp); - end if; - - -- Create temporaries for the actuals that are expressions, or that are - -- scalars and require copying to preserve semantics. - - F := First_Formal (Subp); - A := First_Actual (N); - while Present (F) loop - if Present (Renamed_Object (F)) then - Error_Msg_N ("cannot inline call to recursive subprogram", N); - return; - end if; - - -- Reset Last_Assignment for any parameters of mode out or in out, to - -- prevent spurious warnings about overwriting for assignments to the - -- formal in the inlined code. - - if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then - Set_Last_Assignment (Entity (A), Empty); - end if; - - -- If the argument may be a controlling argument in a call within - -- the inlined body, we must preserve its classwide nature to insure - -- that dynamic dispatching take place subsequently. If the formal - -- has a constraint it must be preserved to retain the semantics of - -- the body. - - if Is_Class_Wide_Type (Etype (F)) - or else (Is_Access_Type (Etype (F)) - and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) - then - Temp_Typ := Etype (F); - - elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) - and then Etype (F) /= Base_Type (Etype (F)) - then - Temp_Typ := Etype (F); - else - Temp_Typ := Etype (A); - end if; - - -- If the actual is a simple name or a literal, no need to - -- create a temporary, object can be used directly. - - -- 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. - - if (Is_Entity_Name (A) - and then - (not Is_Scalar_Type (Etype (A)) - or else Ekind (Entity (A)) = E_Enumeration_Literal)) - - -- 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. - - or else (Nkind (A) = N_Identifier - and then Formal_Is_Used_Once (F)) - - or else - (Nkind_In (A, N_Real_Literal, - N_Integer_Literal, - N_Character_Literal) - and then not Address_Taken (F)) - then - if Etype (F) /= Etype (A) then - Set_Renamed_Object - (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); - else - Set_Renamed_Object (F, A); - end if; - - else - Temp := Make_Temporary (Loc, 'C'); - - -- If the actual for an in/in-out parameter is a view conversion, - -- make it into an unchecked conversion, given that an untagged - -- type conversion is not a proper object for a renaming. - - -- In-out conversions that involve real conversions have already - -- been transformed in Expand_Actuals. - - if Nkind (A) = N_Type_Conversion - and then Ekind (F) /= E_In_Parameter - then - New_A := - Make_Unchecked_Type_Conversion (Loc, - 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)); - Temp_Typ := Etype (F); - - else - New_A := Relocate_Node (A); - end if; - - Set_Sloc (New_A, Sloc (N)); - - -- If the actual has a by-reference type, it cannot be copied, - -- so its value is captured in a renaming declaration. Otherwise - -- declare a local constant initialized with the actual. - - -- We also use a renaming declaration for expressions of an array - -- type that is not bit-packed, both for efficiency reasons and to - -- respect the semantics of the call: in most cases the original - -- call will pass the parameter by reference, and thus the inlined - -- code will have the same semantics. - - if Ekind (F) = E_In_Parameter - and then not Is_By_Reference_Type (Etype (A)) - and then - (not Is_Array_Type (Etype (A)) - or else not Is_Object_Reference (A) - or else Is_Bit_Packed_Array (Etype (A))) - then - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), - Expression => New_A); - else - Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Temp, - Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), - Name => New_A); - end if; - - Append (Decl, Decls); - Set_Renamed_Object (F, Temp); - end if; - - Next_Formal (F); - Next_Actual (A); - end loop; - - -- Establish target of function call. If context is not assignment or - -- declaration, create a temporary as a target. The declaration for the - -- temporary may be subsequently optimized away if the body is a single - -- expression, or if the left-hand side of the assignment is simple - -- enough, i.e. an entity or an explicit dereference of one. - - if Ekind (Subp) = E_Function then - if Nkind (Parent (N)) = N_Assignment_Statement - and then Is_Entity_Name (Name (Parent (N))) - then - Targ := Name (Parent (N)); - - elsif Nkind (Parent (N)) = N_Assignment_Statement - and then Nkind (Name (Parent (N))) = N_Explicit_Dereference - and then Is_Entity_Name (Prefix (Name (Parent (N)))) - then - Targ := Name (Parent (N)); - - elsif Nkind (Parent (N)) = N_Assignment_Statement - and then Nkind (Name (Parent (N))) = N_Selected_Component - and then Is_Entity_Name (Prefix (Name (Parent (N)))) - then - Targ := New_Copy_Tree (Name (Parent (N))); - - elsif Nkind (Parent (N)) = N_Object_Declaration - and then Is_Limited_Type (Etype (Subp)) - then - Targ := Defining_Identifier (Parent (N)); - - -- New semantics: In an object declaration avoid an extra copy - -- of the result of a call to an inlined function that returns - -- an unconstrained type - - elsif Debug_Flag_Dot_K - and then Nkind (Parent (N)) = N_Object_Declaration - and then Is_Unc - then - Targ := Defining_Identifier (Parent (N)); - - else - -- Replace call with temporary and create its declaration - - Temp := Make_Temporary (Loc, 'C'); - Set_Is_Internal (Temp); - - -- For the unconstrained case, the generated temporary has the - -- same constrained declaration as the result variable. It may - -- eventually be possible to remove that temporary and use the - -- result variable directly. - - if Is_Unc - and then Nkind (Parent (N)) /= N_Assignment_Statement - then - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => - New_Copy_Tree (Object_Definition (Parent (Targ1)))); - - Replace_Formals (Decl); - - else - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); - - Set_Etype (Temp, Ret_Type); - end if; - - Set_No_Initialization (Decl); - Append (Decl, Decls); - Rewrite (N, New_Occurrence_Of (Temp, Loc)); - Targ := Temp; - end if; - end if; - - Insert_Actions (N, Decls); - - if Is_Unc_Decl then - - -- Special management for inlining a call to a function that returns - -- an unconstrained type and initializes an object declaration: we - -- avoid generating undesired extra calls and goto statements. - - -- Given: - -- function Func (...) return ... - -- begin - -- declare - -- Result : String (1 .. 4); - -- begin - -- Proc (Result, ...); - -- return Result; - -- end; - -- end F; - - -- Result : String := Func (...); - - -- Replace this object declaration by: - - -- Result : String (1 .. 4); - -- Proc (Result, ...); - - Remove_Homonym (Targ); - - Decl := - Make_Object_Declaration - (Loc, - Defining_Identifier => Targ, - Object_Definition => - New_Copy_Tree (Object_Definition (Parent (Targ1)))); - Replace_Formals (Decl); - Rewrite (Parent (N), Decl); - Analyze (Parent (N)); - - -- Avoid spurious warnings since we know that this declaration is - -- referenced by the procedure call. - - Set_Never_Set_In_Source (Targ, False); - - -- Remove the local declaration of the extended return stmt from the - -- inlined code - - Remove (Parent (Targ1)); - - -- Update the reference to the result (since we have rewriten the - -- object declaration) - - declare - Blk_Call_Stmt : Node_Id; - - begin - -- Capture the call to the procedure - - Blk_Call_Stmt := - First (Statements (Handled_Statement_Sequence (Blk))); - pragma Assert - (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement); - - Remove (First (Parameter_Associations (Blk_Call_Stmt))); - Prepend_To (Parameter_Associations (Blk_Call_Stmt), - New_Occurrence_Of (Targ, Loc)); - end; + end if; - -- Remove the return statement + elsif Optimization_Level > 0 then + Do_Inline (Subp, Orig_Subp); + end if; - pragma Assert - (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = - N_Simple_Return_Statement); + -- The call may have been inlined or may have been passed to + -- the backend. No further action needed if it was inlined. - Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + if Nkind (N) /= N_Function_Call then + return; + end if; + end; + end if; end if; - -- Traverse the tree and replace formals with actuals or their thunks. - -- Attach block to tree before analysis and rewriting. + -- Check for protected subprogram. This is either an intra-object call, + -- or a protected function call. Protected procedure calls are rewritten + -- as entry calls and handled accordingly. - Replace_Formals (Blk); - Set_Parent (Blk, N); + -- In Ada 2005, this may be an indirect call to an access parameter that + -- is an access_to_subprogram. In that case the anonymous type has a + -- scope that is a protected operation, but the call is a regular one. + -- In either case do not expand call if subprogram is eliminated. - if not Comes_From_Source (Subp) or else Is_Predef then - Reset_Slocs (Blk); - end if; + Scop := Scope (Subp); - if Is_Unc_Decl then + if Nkind (Call_Node) /= N_Entry_Call_Statement + and then Is_Protected_Type (Scop) + and then Ekind (Subp) /= E_Subprogram_Type + and then not Is_Eliminated (Subp) + then + -- If the call is an internal one, it is rewritten as a call to the + -- corresponding unprotected subprogram. - -- No action needed since return statement has been already removed + Expand_Protected_Subprogram_Call (Call_Node, Subp, Scop); + end if; - null; + -- Functions returning controlled objects need special attention. If + -- the return type is limited, then the context is initialization and + -- different processing applies. If the call is to a protected function, + -- the expansion above will call Expand_Call recursively. Otherwise the + -- function call is transformed into a temporary which obtains the + -- result from the secondary stack. - elsif Present (Exit_Lab) then + if Needs_Finalization (Etype (Subp)) then + if not Is_Limited_View (Etype (Subp)) + and then + (No (First_Formal (Subp)) + or else + not Is_Concurrent_Record_Type (Etype (First_Formal (Subp)))) + then + Expand_Ctrl_Function_Call (Call_Node); - -- If the body was a single expression, the single return statement - -- and the corresponding label are useless. + -- Build-in-place function calls which appear in anonymous contexts + -- need a transient scope to ensure the proper finalization of the + -- intermediate result after its use. - if Num_Ret = 1 + elsif Is_Build_In_Place_Function_Call (Call_Node) and then - Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = - N_Goto_Statement + Nkind_In (Parent (Call_Node), N_Attribute_Reference, + N_Function_Call, + N_Indexed_Component, + N_Object_Renaming_Declaration, + N_Procedure_Call_Statement, + N_Selected_Component, + N_Slice) then - Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); - else - Append (Lab_Decl, (Declarations (Blk))); - Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); + Establish_Transient_Scope (Call_Node, Sec_Stack => True); end if; end if; + end Expand_Call; - -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors - -- on conflicting private views that Gigi would ignore. If this is a - -- predefined unit, analyze with checks off, as is done in the non- - -- inlined run-time units. - - declare - I_Flag : constant Boolean := In_Inlined_Body; + ------------------------------- + -- Expand_Ctrl_Function_Call -- + ------------------------------- - begin - In_Inlined_Body := True; + procedure Expand_Ctrl_Function_Call (N : Node_Id) is + function Is_Element_Reference (N : Node_Id) return Boolean; + -- Determine whether node N denotes a reference to an Ada 2012 container + -- element. - if Is_Predef then - declare - Style : constant Boolean := Style_Check; + -------------------------- + -- Is_Element_Reference -- + -------------------------- - begin - Style_Check := False; + function Is_Element_Reference (N : Node_Id) return Boolean is + Ref : constant Node_Id := Original_Node (N); - -- Search for dispatching calls that use the Object.Operation - -- notation using an Object that is a parameter of the inlined - -- function. We reset the decoration of Operation to force - -- the reanalysis of the inlined dispatching call because - -- the actual object has been inlined. + begin + -- Analysis marks an element reference by setting the generalized + -- indexing attribute of an indexed component before the component + -- is rewritten into a function call. - Reset_Dispatching_Calls (Blk); + return + Nkind (Ref) = N_Indexed_Component + and then Present (Generalized_Indexing (Ref)); + end Is_Element_Reference; - Analyze (Blk, Suppress => All_Checks); - Style_Check := Style; - end; + -- Local variables - else - Analyze (Blk); - end if; + Is_Elem_Ref : constant Boolean := Is_Element_Reference (N); - In_Inlined_Body := I_Flag; - end; + -- Start of processing for Expand_Ctrl_Function_Call - if Ekind (Subp) = E_Procedure then - Rewrite_Procedure_Call (N, Blk); + begin + -- Optimization, if the returned value (which is on the sec-stack) is + -- returned again, no need to copy/readjust/finalize, we can just pass + -- the value thru (see Expand_N_Simple_Return_Statement), and thus no + -- attachment is needed - else - Rewrite_Function_Call (N, Blk); + if Nkind (Parent (N)) = N_Simple_Return_Statement then + return; + end if; - if Is_Unc_Decl then - null; + -- Resolution is now finished, make sure we don't start analysis again + -- because of the duplication. - -- For the unconstrained case, the replacement of the call has been - -- made prior to the complete analysis of the generated declarations. - -- Propagate the proper type now. + Set_Analyzed (N); - elsif Is_Unc then - if Nkind (N) = N_Identifier then - Set_Etype (N, Etype (Entity (N))); - else - Set_Etype (N, Etype (Targ1)); - end if; - end if; - end if; + -- A function which returns a controlled object uses the secondary + -- stack. Rewrite the call into a temporary which obtains the result of + -- the function using 'reference. - Restore_Env; + Remove_Side_Effects (N); - -- Cleanup mapping between formals and actuals for other expansions + -- 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. + -- Such references must be finalized at the end of each iteration of the + -- related quantified expression, otherwise the container will remain + -- busy. - F := First_Formal (Subp); - while Present (F) loop - Set_Renamed_Object (F, Empty); - Next_Formal (F); - end loop; - end Expand_Inlined_Call; + if not Is_Elem_Ref + and then Within_Case_Or_If_Expression (N) + and then Nkind (N) = N_Explicit_Dereference + then + Set_Is_Processed_Transient (Entity (Prefix (N))); + end if; + end Expand_Ctrl_Function_Call; ---------------------------------------- -- Expand_N_Extended_Return_Statement -- @@ -6350,21 +5064,6 @@ package body Exp_Ch6 is procedure Expand_N_Function_Call (N : Node_Id) is begin Expand_Call (N); - - -- If the return value of a foreign compiled function is VAX Float, then - -- expand the return (adjusts the location of the return value on - -- Alpha/VMS, no-op everywhere else). - -- Comes_From_Source intercepts recursive expansion. - - if Nkind (N) = N_Function_Call - and then Vax_Float (Etype (N)) - and then Present (Name (N)) - and then Present (Entity (Name (N))) - and then Has_Foreign_Convention (Entity (Name (N))) - and then Comes_From_Source (Parent (N)) - then - Expand_Vax_Foreign_Return (N); - end if; end Expand_N_Function_Call; --------------------------------------- @@ -6510,6 +5209,13 @@ package body Exp_Ch6 is -- Analyze call, but something goes wrong in some weird cases -- and it is not worth worrying about ??? + -- The return statement is handled properly, and the call + -- to the postcondition, inserted below, does not require + -- information from the body either. However, that call is + -- analyzed in the enclosing scope, and an elaboration check + -- might improperly be added to it. A guard in Sem_Elab is + -- needed to prevent that spurious check, see Check_Elab_Call. + Append_To (S, Rtn); Set_Analyzed (Rtn); @@ -6859,7 +5565,7 @@ package body Exp_Ch6 is if Nkind (Parent (N)) /= N_Package_Specification then if Nkind (Parent (N)) = N_Compilation_Unit then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subprogram declaration is not a library item", N); elsif Present (Next (N)) @@ -6873,7 +5579,7 @@ package body Exp_Ch6 is null; else - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subprogram declaration is not allowed here", N); end if; end if; @@ -8250,10 +6956,6 @@ package body Exp_Ch6 is -- subprogram Subp_Id must appear visible from the point of view of -- the type. - function Predicate_Checks_OK (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ can benefit from predicate checks. To - -- qualify, the type must have at least one checked predicate. - --------------------------------- -- Add_Invariant_Access_Checks -- --------------------------------- @@ -8416,57 +7118,6 @@ package body Exp_Ch6 is and then Has_Public_Visibility_Of_Subprogram; end Invariant_Checks_OK; - ------------------------- - -- Predicate_Checks_OK -- - ------------------------- - - function Predicate_Checks_OK (Typ : Entity_Id) return Boolean is - function Has_Checked_Predicate return Boolean; - -- Determine whether type Typ has or inherits at least one - -- predicate aspect or pragma, for which the applicable policy is - -- Checked. - - --------------------------- - -- Has_Checked_Predicate -- - --------------------------- - - function Has_Checked_Predicate return Boolean is - Anc : Entity_Id; - Pred : Node_Id; - - begin - -- Climb the ancestor type chain staring from the input. This - -- is done because the input type may lack aspect/pragma - -- predicate and simply inherit those from its ancestor. - - -- Note that predicate pragmas correspond to all three cases - -- of predicate aspects (Predicate, Dynamic_Predicate, and - -- Static_Predicate), so this routine checks for all three - -- cases. - - Anc := Typ; - while Present (Anc) loop - Pred := Get_Pragma (Anc, Pragma_Predicate); - - if Present (Pred) and then not Is_Ignored (Pred) then - return True; - end if; - - Anc := Nearest_Ancestor (Anc); - end loop; - - return False; - end Has_Checked_Predicate; - - -- Start of processing for Predicate_Checks_OK - - begin - return - Has_Predicates (Typ) - and then Present (Predicate_Function (Typ)) - and then Has_Checked_Predicate; - end Predicate_Checks_OK; - -- Local variables Loc : constant Source_Ptr := Sloc (N); @@ -8531,12 +7182,11 @@ package body Exp_Ch6 is Add_Invariant_Access_Checks (Formal); - if Predicate_Checks_OK (Typ) then - Append_Enabled_Item - (Item => Make_Predicate_Check - (Typ, New_Occurrence_Of (Formal, Loc)), - List => Stmts); - end if; + -- Note: we used to add predicate checks for OUT and IN OUT + -- formals here, but that was misguided, since such checks are + -- performed on the caller side, based on the predicate of the + -- actual, rather than the predicate of the formal. + end if; Next_Formal (Formal); @@ -9720,10 +8370,16 @@ package body Exp_Ch6 is Acc_Type : constant Entity_Id := Etype (Allocator); Loc : Source_Ptr; Func_Call : Node_Id := Function_Call; + Ref_Func_Call : Node_Id; Function_Id : Entity_Id; Result_Subt : Entity_Id; New_Allocator : Node_Id; - Return_Obj_Access : Entity_Id; + Return_Obj_Access : Entity_Id; -- temp for function result + Temp_Init : Node_Id; -- initial value of Return_Obj_Access + Alloc_Form : BIP_Allocation_Form; + Pool : Node_Id; -- nonnull if Alloc_Form = User_Storage_Pool + Return_Obj_Actual : Node_Id; -- the temp.all, in caller-allocates case + Chain : Entity_Id; -- activation chain, in case of tasks begin -- Step past qualification or unchecked conversion (the latter can occur @@ -9762,14 +8418,16 @@ package body Exp_Ch6 is Result_Subt := Available_View (Etype (Function_Id)); - -- Check whether return type includes tasks. This may not have been done - -- previously, if the type was a limited view. + -- Create a temp for the function result. In the caller-allocates case, + -- this will be initialized to the result of a new uninitialized + -- allocator. Note: we do not use Allocator as the Related_Node of + -- Return_Obj_Access in call to Make_Temporary below as this would + -- create a sort of infinite "recursion". - if Has_Task (Result_Subt) then - Build_Activation_Chain_Entity (Allocator); - end if; + Return_Obj_Access := Make_Temporary (Loc, 'R'); + Set_Etype (Return_Obj_Access, Acc_Type); - -- When the result subtype is constrained, the return object must be + -- When the result subtype is constrained, the return object is -- allocated on the caller side, and access to it is passed to the -- function. @@ -9801,57 +8459,29 @@ package body Exp_Ch6 is Rewrite (Allocator, New_Allocator); - -- Create a new access object and initialize it to the result of the - -- new uninitialized allocator. Note: we do not use Allocator as the - -- Related_Node of Return_Obj_Access in call to Make_Temporary below - -- as this would create a sort of infinite "recursion". - - Return_Obj_Access := Make_Temporary (Loc, 'R'); - Set_Etype (Return_Obj_Access, Acc_Type); - - Insert_Action (Allocator, - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Access, - Object_Definition => New_Occurrence_Of (Acc_Type, Loc), - Expression => Relocate_Node (Allocator))); - - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. - - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type); + -- Initial value of the temp is the result of the uninitialized + -- allocator - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); + Temp_Init := Relocate_Node (Allocator); - -- Add an implicit actual to the function call that provides access - -- to the allocated object. An unchecked conversion to the (specific) - -- result subtype of the function is inserted to handle cases where - -- the access type of the allocator has a class-wide designated type. + -- Indicate that caller allocates, and pass in the return object - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, - Function_Id, - Make_Unchecked_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), - Expression => - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)))); + Alloc_Form := Caller_Allocation; + Pool := Make_Null (No_Location); + Return_Obj_Actual := + Make_Unchecked_Type_Conversion (Loc, + Subtype_Mark => New_Occurrence_Of (Result_Subt, Loc), + Expression => + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Return_Obj_Access, Loc))); -- When the result subtype is unconstrained, the function itself must -- perform the allocation of the return object, so we pass parameters - -- indicating that. We don't yet handle the case where the allocation - -- must be done in a user-defined storage pool, which will require - -- passing another actual or two to provide allocation/deallocation - -- operations. ??? + -- indicating that. else + Temp_Init := Empty; + -- Case of a user-defined storage pool. Pass an allocation parameter -- indicating that the function should allocate its result in the -- pool, and pass the pool. Use 'Unrestricted_Access because the @@ -9860,36 +8490,103 @@ package body Exp_Ch6 is if VM_Target = No_VM and then Present (Associated_Storage_Pool (Acc_Type)) then - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => User_Storage_Pool, - Pool_Actual => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of - (Associated_Storage_Pool (Acc_Type), Loc), - Attribute_Name => Name_Unrestricted_Access)); + Alloc_Form := User_Storage_Pool; + Pool := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Associated_Storage_Pool (Acc_Type), Loc), + Attribute_Name => Name_Unrestricted_Access); -- No user-defined pool; pass an allocation parameter indicating that -- the function should allocate its result on the heap. else - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Global_Heap); + Alloc_Form := Global_Heap; + Pool := Make_Null (No_Location); end if; - Add_Finalization_Master_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Acc_Type); - - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type)); - -- The caller does not provide the return object in this case, so we -- have to pass null for the object access actual. - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, Return_Object => Empty); + Return_Obj_Actual := Empty; + end if; + + -- Declare the temp object + + Insert_Action (Allocator, + Make_Object_Declaration (Loc, + Defining_Identifier => Return_Obj_Access, + Object_Definition => New_Occurrence_Of (Acc_Type, Loc), + Expression => Temp_Init)); + + Ref_Func_Call := Make_Reference (Loc, Func_Call); + + -- Ada 2005 (AI-251): If the type of the allocator is an interface + -- then generate an implicit conversion to force displacement of the + -- "this" pointer. + + if Is_Interface (Designated_Type (Acc_Type)) then + Rewrite + (Ref_Func_Call, + OK_Convert_To (Acc_Type, Ref_Func_Call)); end if; + declare + Assign : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Return_Obj_Access, Loc), + Expression => Ref_Func_Call); + -- Assign the result of the function call into the temp. In the + -- caller-allocates case, this is overwriting the temp with its + -- initial value, which has no effect. In the callee-allocates case, + -- this is setting the temp to point to the object allocated by the + -- callee. + + Actions : List_Id; + -- Actions to be inserted. If there are no tasks, this is just the + -- assignment statement. If the allocated object has tasks, we need + -- to wrap the assignment in a block that activates them. The + -- activation chain of that block must be passed to the function, + -- rather than some outer chain. + begin + if Has_Task (Result_Subt) then + Actions := New_List; + Build_Task_Allocate_Block_With_Init_Stmts + (Actions, Allocator, Init_Stmts => New_List (Assign)); + Chain := Activation_Chain_Entity (Last (Actions)); + else + Actions := New_List (Assign); + Chain := Empty; + end if; + + Insert_Actions (Allocator, Actions); + end; + + -- When the function has a controlling result, an allocation-form + -- parameter must be passed indicating that the caller is allocating + -- the result object. This is needed because such a function can be + -- called as a dispatching operation and must be treated similarly + -- to functions with unconstrained result subtypes. + + Add_Unconstrained_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Alloc_Form, Pool_Actual => Pool); + + Add_Finalization_Master_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Acc_Type); + + Add_Task_Actuals_To_Build_In_Place_Call + (Func_Call, Function_Id, Master_Actual => Master_Id (Acc_Type), + Chain => Chain); + + -- Add an implicit actual to the function call that provides access + -- to the allocated object. An unchecked conversion to the (specific) + -- result subtype of the function is inserted to handle cases where + -- the access type of the allocator has a class-wide designated type. + + Add_Access_Actual_To_Build_In_Place_Call + (Func_Call, Function_Id, Return_Obj_Actual); + -- If the build-in-place function call returns a controlled object, -- the finalization master will require a reference to routine -- Finalize_Address of the designated type. Setting this attribute @@ -9917,19 +8614,9 @@ package body Exp_Ch6 is end if; end if; - -- Finally, replace the allocator node with a reference to the result - -- of the function call itself (which will effectively be an access - -- to the object created by the allocator). - - Rewrite (Allocator, Make_Reference (Loc, Relocate_Node (Function_Call))); - - -- Ada 2005 (AI-251): If the type of the allocator is an interface then - -- generate an implicit conversion to force displacement of the "this" - -- pointer. + -- Finally, replace the allocator node with a reference to the temp - if Is_Interface (Designated_Type (Acc_Type)) then - Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator))); - end if; + Rewrite (Allocator, New_Occurrence_Of (Return_Obj_Access, Loc)); Analyze_And_Resolve (Allocator, Acc_Type); end Make_Build_In_Place_Call_In_Allocator; @@ -10831,75 +9518,4 @@ package body Exp_Ch6 is end if; end Needs_Result_Accessibility_Level; - ------------------------ - -- List_Inlining_Info -- - ------------------------ - - procedure List_Inlining_Info is - Elmt : Elmt_Id; - Nod : Node_Id; - Count : Nat; - - begin - if not Debug_Flag_Dot_J then - return; - end if; - - -- Generate listing of calls inlined by the frontend - - if Present (Inlined_Calls) then - Count := 0; - Elmt := First_Elmt (Inlined_Calls); - while Present (Elmt) loop - Nod := Node (Elmt); - - if In_Extended_Main_Code_Unit (Nod) then - Count := Count + 1; - - if Count = 1 then - Write_Str ("Listing of frontend inlined calls"); - Write_Eol; - end if; - - Write_Str (" "); - Write_Int (Count); - Write_Str (":"); - Write_Location (Sloc (Nod)); - Write_Str (":"); - Output.Write_Eol; - end if; - - Next_Elmt (Elmt); - end loop; - end if; - - -- Generate listing of calls passed to the backend - - if Present (Backend_Calls) then - Count := 0; - - Elmt := First_Elmt (Backend_Calls); - while Present (Elmt) loop - Nod := Node (Elmt); - - if In_Extended_Main_Code_Unit (Nod) then - Count := Count + 1; - - if Count = 1 then - Write_Str ("Listing of inlined calls passed to the backend"); - Write_Eol; - end if; - - Write_Str (" "); - Write_Int (Count); - Write_Str (":"); - Write_Location (Sloc (Nod)); - Output.Write_Eol; - end if; - - Next_Elmt (Elmt); - end loop; - end if; - end List_Inlining_Info; - end Exp_Ch6; diff --git a/main/gcc/ada/exp_ch6.ads b/main/gcc/ada/exp_ch6.ads index 801a5a2a61a..0c31ea6c3b4 100644 --- a/main/gcc/ada/exp_ch6.ads +++ b/main/gcc/ada/exp_ch6.ads @@ -139,10 +139,6 @@ package Exp_Ch6 is -- Predicate to recognize stubbed procedures and null procedures, which -- can be inlined unconditionally in all cases. - procedure List_Inlining_Info; - -- Generate listing of calls inlined by the frontend plus listing of - -- calls to inline subprograms passed to the backend. - procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; Function_Call : Node_Id); diff --git a/main/gcc/ada/exp_ch7.adb b/main/gcc/ada/exp_ch7.adb index 748279b60b6..b98aed6bbab 100644 --- a/main/gcc/ada/exp_ch7.adb +++ b/main/gcc/ada/exp_ch7.adb @@ -38,6 +38,7 @@ with Exp_Ch11; use Exp_Ch11; with Exp_Dbug; use Exp_Dbug; with Exp_Dist; use Exp_Dist; with Exp_Disp; use Exp_Disp; +with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; @@ -130,9 +131,14 @@ package body Exp_Ch7 is -- pointers of N until it find the appropriate node to wrap. If it returns -- Empty, it means that no transient scope is needed in this context. - procedure Insert_Actions_In_Scope_Around (N : Node_Id); + procedure Insert_Actions_In_Scope_Around + (N : Node_Id; + Clean : Boolean; + Manage_SS : Boolean); -- Insert the before-actions kept in the scope stack before N, and the - -- after-actions after N, which must be a member of a list. + -- after-actions after N, which must be a member of a list. If flag Clean + -- is set, insert any cleanup actions. If flag Manage_SS is set, insert + -- calls to mark and release the secondary stack. function Make_Transient_Block (Loc : Source_Ptr; @@ -374,11 +380,6 @@ package body Exp_Ch7 is -- Given an arbitrary entity, traverse the scope chain looking for the -- first enclosing function. Return Empty if no function was found. - procedure Expand_Pragma_Initial_Condition (N : Node_Id); - -- Subsidiary to the expansion of package specs and bodies. Generate a - -- runtime check needed to verify the assumption introduced by pragma - -- Initial_Condition. N denotes the package spec or body. - function Make_Call (Loc : Source_Ptr; Proc_Id : Entity_Id; @@ -870,9 +871,7 @@ package body Exp_Ch7 is -- types where the designated type is explicitly derived from [Limited_] -- Controlled. - elsif VM_Target /= No_VM - and then not Is_Controlled (Desig_Typ) - then + elsif VM_Target /= No_VM and then not Is_Controlled (Desig_Typ) then return; -- Do not create finalization masters in SPARK mode because they result @@ -933,7 +932,7 @@ package body Exp_Ch7 is -- The default choice is the global pool else - Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ); + Pool_Id := RTE (RE_Global_Pool_Object); Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id); end if; @@ -1476,12 +1475,7 @@ package body Exp_Ch7 is -- Release the secondary stack mark if Present (Mark_Id) then - Append_To (Finalizer_Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_SS_Release), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Mark_Id, Loc)))); + Append_To (Finalizer_Stmts, Build_SS_Release_Call (Loc, Mark_Id)); end if; -- Protect the statements with abort defer/undefer. This is only when @@ -1609,7 +1603,7 @@ package body Exp_Ch7 is -- When the finalizer acts solely as a clean up routine, the body -- is inserted right after the spec. - if Acts_As_Clean and then not Has_Ctrl_Objs then + if Acts_As_Clean and not Has_Ctrl_Objs then Insert_After (Fin_Spec, Fin_Body); -- In all other cases the body is inserted after either: @@ -1817,9 +1811,7 @@ package body Exp_Ch7 is elsif Is_Access_Type (Obj_Typ) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Object_Declaration - and then Is_Finalizable_Transient - (Status_Flag_Or_Transient_Decl (Obj_Id), Decl) + N_Object_Declaration then Processing_Actions (Has_No_Init => True); @@ -1869,9 +1861,8 @@ package body Exp_Ch7 is elsif Ekind (Obj_Id) = E_Variable and then not In_Library_Level_Package_Body (Obj_Id) - and then - (Is_Simple_Protected_Type (Obj_Typ) - or else Has_Simple_Protected_Object (Obj_Typ)) + and then (Is_Simple_Protected_Type (Obj_Typ) + or else Has_Simple_Protected_Object (Obj_Typ)) then Processing_Actions (Is_Protected => True); end if; @@ -2066,13 +2057,20 @@ package body Exp_Ch7 is Has_No_Init : Boolean := False; Is_Protected : Boolean := False) is - Loc : constant Source_Ptr := Sloc (Decl); + Loc : constant Source_Ptr := Sloc (Decl); + Obj_Id : constant Entity_Id := Defining_Identifier (Decl); - function Build_BIP_Cleanup_Stmts - (Func_Id : Entity_Id; - Obj_Id : Entity_Id) return Node_Id; - -- Func_Id denotes a build-in-place function. Obj_Id is the return - -- object of Func_Id. Generate the following cleanup code: + 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 + -- possible type derivations. + + Obj_Typ : Entity_Id; + -- The type of the related object declaration + + function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id; + -- Func_Id denotes a build-in-place function. Generate the following + -- cleanup code: -- -- if BIPallocfrom > Secondary_Stack'Pos -- and then BIPfinalizationmaster /= null @@ -2090,27 +2088,25 @@ package body Exp_Ch7 is -- allocation which Obj_Id renames. procedure Find_Last_Init - (Decl : Node_Id; - Last_Init : out Node_Id; + (Last_Init : out Node_Id; Body_Insert : out Node_Id); -- Find the last initialization call related to object declaration -- Decl. Last_Init denotes the last initialization call which follows - -- Decl. Body_Insert denotes the finalizer body could be potentially - -- inserted. + -- Decl. Body_Insert denotes a node where the finalizer body could be + -- potentially inserted after (if blocks are involved). ----------------------------- -- Build_BIP_Cleanup_Stmts -- ----------------------------- function Build_BIP_Cleanup_Stmts - (Func_Id : Entity_Id; - Obj_Id : Entity_Id) return Node_Id + (Func_Id : Entity_Id) return Node_Id is Decls : constant List_Id := New_List; Fin_Mas_Id : constant Entity_Id := Build_In_Place_Formal (Func_Id, BIP_Finalization_Master); - Obj_Typ : constant Entity_Id := Etype (Func_Id); + Func_Typ : constant Entity_Id := Etype (Func_Id); Temp_Id : constant Entity_Id := Entity (Prefix (Name (Parent (Obj_Id)))); @@ -2146,7 +2142,7 @@ package body Exp_Ch7 is -- caller's finalization master. -- Generate: - -- type Ptr_Typ is access Obj_Typ; + -- type Ptr_Typ is access Func_Typ; Ptr_Typ := Make_Temporary (Loc, 'P'); @@ -2155,7 +2151,7 @@ package body Exp_Ch7 is Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, - Subtype_Indication => New_Occurrence_Of (Obj_Typ, Loc)))); + Subtype_Indication => New_Occurrence_Of (Func_Typ, Loc)))); -- Perform minor decoration in order to set the master and the -- storage pool attributes. @@ -2202,13 +2198,13 @@ package body Exp_Ch7 is -- For constrained or tagged results escalate the condition to -- include the allocation format. Generate: - -- + -- if BIPallocform > Secondary_Stack'Pos -- and then BIPfinalizationmaster /= null -- then - if not Is_Constrained (Obj_Typ) - or else Is_Tagged_Type (Obj_Typ) + if not Is_Constrained (Func_Typ) + or else Is_Tagged_Type (Func_Typ) then declare Alloc : constant Entity_Id := @@ -2244,21 +2240,16 @@ package body Exp_Ch7 is -------------------- procedure Find_Last_Init - (Decl : Node_Id; - Last_Init : out Node_Id; + (Last_Init : out Node_Id; Body_Insert : out Node_Id) is - function Find_Last_Init_In_Block - (Blk : Node_Id; - Init_Typ : Entity_Id) return Node_Id; + function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id; -- Find the last initialization call within the statements of - -- block Blk. Init_Typ is type of the object being initialized. + -- block Blk. - function Is_Init_Call - (N : Node_Id; - Init_Typ : Entity_Id) return Boolean; + function Is_Init_Call (N : Node_Id) return Boolean; -- Determine whether node N denotes one of the initialization - -- procedures of type Init_Typ. + -- procedures of types Init_Typ or Obj_Typ. function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id; -- Given a statement which is part of a list, return the next @@ -2268,10 +2259,7 @@ package body Exp_Ch7 is -- Find_Last_Init_In_Block -- ----------------------------- - function Find_Last_Init_In_Block - (Blk : Node_Id; - Init_Typ : Entity_Id) return Node_Id - is + function Find_Last_Init_In_Block (Blk : Node_Id) return Node_Id is HSS : constant Node_Id := Handled_Statement_Sequence (Blk); Stmt : Node_Id; @@ -2286,9 +2274,9 @@ package body Exp_Ch7 is -- Peek inside nested blocks in case aborts are allowed if Nkind (Stmt) = N_Block_Statement then - return Find_Last_Init_In_Block (Stmt, Init_Typ); + return Find_Last_Init_In_Block (Stmt); - elsif Is_Init_Call (Stmt, Init_Typ) then + elsif Is_Init_Call (Stmt) then return Stmt; end if; @@ -2303,33 +2291,38 @@ package body Exp_Ch7 is -- Is_Init_Call -- ------------------ - function Is_Init_Call - (N : Node_Id; - Init_Typ : Entity_Id) return Boolean - is - Call_Id : Entity_Id; - Deep_Init : Entity_Id := Empty; - Prim_Init : Entity_Id := Empty; - Type_Init : Entity_Id := Empty; - - begin - if Nkind (N) = N_Procedure_Call_Statement - and then Nkind (Name (N)) = N_Identifier - then - Call_Id := Entity (Name (N)); + function Is_Init_Call (N : Node_Id) return Boolean is + function Is_Init_Proc_Of + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a valid init proc of + -- type Typ. + + --------------------- + -- Is_Init_Proc_Of -- + --------------------- + + function Is_Init_Proc_Of + (Subp_Id : Entity_Id; + Typ : Entity_Id) return Boolean + is + Deep_Init : Entity_Id := Empty; + Prim_Init : Entity_Id := Empty; + Type_Init : Entity_Id := Empty; - -- Obtain all possible initialization routines of the object - -- type and try to match the procedure call against one of - -- them. + begin + -- Obtain all possible initialization routines of the + -- related type and try to match the subprogram entity + -- against one of them. -- Deep_Initialize - Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize); + Deep_Init := TSS (Typ, TSS_Deep_Initialize); -- Primitive Initialize - if Is_Controlled (Init_Typ) then - Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize); + if Is_Controlled (Typ) then + Prim_Init := Find_Prim_Op (Typ, Name_Initialize); if Present (Prim_Init) then Prim_Init := Ultimate_Alias (Prim_Init); @@ -2338,16 +2331,37 @@ package body Exp_Ch7 is -- Type initialization routine - if Has_Non_Null_Base_Init_Proc (Init_Typ) then - Type_Init := Base_Init_Proc (Init_Typ); + if Has_Non_Null_Base_Init_Proc (Typ) then + Type_Init := Base_Init_Proc (Typ); end if; return - (Present (Deep_Init) and then Call_Id = Deep_Init) + (Present (Deep_Init) and then Subp_Id = Deep_Init) or else - (Present (Prim_Init) and then Call_Id = Prim_Init) + (Present (Prim_Init) and then Subp_Id = Prim_Init) or else - (Present (Type_Init) and then Call_Id = Type_Init); + (Present (Type_Init) and then Subp_Id = Type_Init); + end Is_Init_Proc_Of; + + -- Local variables + + Call_Id : Entity_Id; + + -- Start of processing for Is_Init_Call + + begin + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Name (N)) = N_Identifier + then + Call_Id := Entity (Name (N)); + + -- Consider both the type of the object declaration and its + -- related initialization type. + + return + Is_Init_Proc_Of (Call_Id, Init_Typ) + or else + Is_Init_Proc_Of (Call_Id, Obj_Typ); end if; return False; @@ -2374,13 +2388,12 @@ package body Exp_Ch7 is -- Local variables - Obj_Id : constant Entity_Id := Defining_Entity (Decl); - Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); - Call : Node_Id; - Init_Typ : Entity_Id := Obj_Typ; - Is_Conc : Boolean := False; - Stmt : Node_Id; - Stmt_2 : Node_Id; + Call : Node_Id; + Stmt : Node_Id; + Stmt_2 : Node_Id; + + Deep_Init_Found : Boolean := False; + -- A flag set when a call to [Deep_]Initialize has been found -- Start of processing for Find_Last_Init @@ -2395,34 +2408,6 @@ package body Exp_Ch7 is return; end if; - -- Obtain the proper type of the object being initialized - - loop - if Is_Concurrent_Type (Init_Typ) - and then Present (Corresponding_Record_Type (Init_Typ)) - then - Is_Conc := True; - Init_Typ := Corresponding_Record_Type (Init_Typ); - - elsif Is_Private_Type (Init_Typ) - and then Present (Full_View (Init_Typ)) - then - Init_Typ := Full_View (Init_Typ); - - elsif Is_Untagged_Derivation (Init_Typ) - and then not Is_Conc - then - Init_Typ := Root_Type (Init_Typ); - - else - exit; - end if; - end loop; - - if Init_Typ /= Base_Type (Init_Typ) then - Init_Typ := Base_Type (Init_Typ); - end if; - Stmt := Next_Suitable_Statement (Decl); -- A limited controlled object initialized by a function call uses @@ -2442,7 +2427,7 @@ package body Exp_Ch7 is -- In this scenario the declaration of the temporary acts as the -- last initialization statement. - if Is_Limited_Type (Init_Typ) + if Is_Limited_Type (Obj_Typ) and then Has_Init_Expression (Decl) and then No (Expression (Decl)) then @@ -2460,6 +2445,15 @@ package body Exp_Ch7 is 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 + return; + -- In all other cases the initialization calls follow the related -- object. The general structure of object initialization built by -- routine Default_Initialize_Object is as follows: @@ -2482,7 +2476,7 @@ package body Exp_Ch7 is -- within a block. elsif Nkind (Stmt) = N_Block_Statement then - Last_Init := Find_Last_Init_In_Block (Stmt, Init_Typ); + Last_Init := Find_Last_Init_In_Block (Stmt); Body_Insert := Stmt; -- Otherwise the initialization calls follow the related object @@ -2496,22 +2490,25 @@ package body Exp_Ch7 is if Present (Stmt_2) then if Nkind (Stmt_2) = N_Block_Statement then - Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ); + Call := Find_Last_Init_In_Block (Stmt_2); if Present (Call) then - Last_Init := Call; - Body_Insert := Stmt_2; + Deep_Init_Found := True; + Last_Init := Call; + Body_Insert := Stmt_2; end if; - elsif Is_Init_Call (Stmt_2, Init_Typ) then - Last_Init := Stmt_2; - Body_Insert := Last_Init; + elsif Is_Init_Call (Stmt_2) then + Deep_Init_Found := True; + Last_Init := Stmt_2; + Body_Insert := Last_Init; end if; + end if; -- If the object lacks a call to Deep_Initialize, then it must -- have a call to its related type init proc. - elsif Is_Init_Call (Stmt, Init_Typ) then + if not Deep_Init_Found and then Is_Init_Call (Stmt) then Last_Init := Stmt; Body_Insert := Last_Init; end if; @@ -2520,7 +2517,6 @@ package body Exp_Ch7 is -- Local variables - Obj_Id : constant Entity_Id := Defining_Identifier (Decl); Body_Ins : Node_Id; Count_Ins : Node_Id; Fin_Call : Node_Id; @@ -2529,23 +2525,60 @@ package body Exp_Ch7 is Label : Node_Id; Label_Id : Entity_Id; Obj_Ref : Node_Id; - Obj_Typ : Entity_Id; -- Start of processing for Process_Object_Declaration begin + -- Handle the object type and the reference to the object + Obj_Ref := New_Occurrence_Of (Obj_Id, Loc); Obj_Typ := Base_Type (Etype (Obj_Id)); - -- Handle access types + loop + if Is_Access_Type (Obj_Typ) then + Obj_Typ := Directly_Designated_Type (Obj_Typ); + Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - if Is_Access_Type (Obj_Typ) then - Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref); - Obj_Typ := Directly_Designated_Type (Obj_Typ); - end if; + elsif Is_Concurrent_Type (Obj_Typ) + and then Present (Corresponding_Record_Type (Obj_Typ)) + then + Obj_Typ := Corresponding_Record_Type (Obj_Typ); + Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + + elsif Is_Private_Type (Obj_Typ) + and then Present (Full_View (Obj_Typ)) + then + Obj_Typ := Full_View (Obj_Typ); + Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + + elsif Obj_Typ /= Base_Type (Obj_Typ) then + Obj_Typ := Base_Type (Obj_Typ); + Obj_Ref := Unchecked_Convert_To (Obj_Typ, Obj_Ref); + + else + exit; + end if; + end loop; Set_Etype (Obj_Ref, Obj_Typ); + -- Handle the initialization type of the object declaration + + Init_Typ := Obj_Typ; + loop + if Is_Private_Type (Init_Typ) + and then Present (Full_View (Init_Typ)) + then + Init_Typ := Full_View (Init_Typ); + + elsif Is_Untagged_Derivation (Init_Typ) then + Init_Typ := Root_Type (Init_Typ); + + else + exit; + end if; + end loop; + -- Set a new value for the state counter and insert the statement -- after the object declaration. Generate: @@ -2571,7 +2604,7 @@ package body Exp_Ch7 is -- either [Deep_]Initialize or the type specific init proc. else - Find_Last_Init (Decl, Count_Ins, Body_Ins); + Find_Last_Init (Count_Ins, Body_Ins); end if; Insert_After (Count_Ins, Inc_Decl); @@ -2754,8 +2787,7 @@ package body Exp_Ch7 is if Is_Build_In_Place_Function (Func_Id) and then Needs_BIP_Finalization_Master (Func_Id) then - Append_To - (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id, Obj_Id)); + Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id)); end if; end; end if; @@ -2911,13 +2943,13 @@ package body Exp_Ch7 is and then (not Is_Library_Level_Entity (Spec_Id) - -- Nested packages are considered to be library level entities, - -- but do not need to be processed separately. True library level - -- packages have a scope value of 1. + -- Nested packages are considered to be library level entities, + -- but do not need to be processed separately. True library level + -- packages have a scope value of 1. - or else Scope_Depth_Value (Spec_Id) /= Uint_1 - or else (Is_Generic_Instance (Spec_Id) - and then Package_Instantiation (Spec_Id) /= N)) + or else Scope_Depth_Value (Spec_Id) /= Uint_1 + or else (Is_Generic_Instance (Spec_Id) + and then Package_Instantiation (Spec_Id) /= N)) then return; end if; @@ -3108,8 +3140,11 @@ package body Exp_Ch7 is Loc : Source_Ptr; For_Package : Boolean := False) is - A_Expr : Node_Id; - E_Decl : Node_Id; + Decl : Node_Id; + + Dummy : Entity_Id; + -- This variable captures an unused dummy internal entity, see the + -- comment associated with its use. begin pragma Assert (Decls /= No_List); @@ -3138,56 +3173,61 @@ package body Exp_Ch7 is -- does not include routine Raise_From_Controlled_Operation which is the -- the sole user of flag Abort. - -- This is not needed for library-level finalizers as they are called - -- by the environment task and cannot be aborted. + -- This is not needed for library-level finalizers as they are called by + -- the environment task and cannot be aborted. - if Abort_Allowed - and then VM_Target = No_VM - and then not For_Package - then - Data.Abort_Id := Make_Temporary (Loc, 'A'); + if VM_Target = No_VM and then not For_Package then + if Abort_Allowed then + Data.Abort_Id := Make_Temporary (Loc, 'A'); - A_Expr := New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc); + -- Generate: + -- Abort_Id : constant Boolean := ; - -- Generate: + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Data.Abort_Id, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + New_Occurrence_Of (RTE (RE_Triggered_By_Abort), Loc))); - -- Abort_Id : constant Boolean := ; + -- Abort is not required - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Data.Abort_Id, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), - Expression => A_Expr)); + else + -- Generate a dummy entity to ensure that the internal symbols are + -- in sync when a unit is compiled with and without aborts. - else - -- No abort, .NET/JVM or library-level finalizers + Dummy := Make_Temporary (Loc, 'A'); + Data.Abort_Id := Empty; + end if; - Data.Abort_Id := Empty; + -- .NET/JVM or library-level finalizers + + else + Data.Abort_Id := Empty; end if; if Exception_Extra_Info then - Data.E_Id := Make_Temporary (Loc, 'E'); + Data.E_Id := Make_Temporary (Loc, 'E'); -- Generate: - -- E_Id : Exception_Occurrence; - E_Decl := + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Data.E_Id, Object_Definition => New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)); - Set_No_Initialization (E_Decl); + Set_No_Initialization (Decl); - Append_To (Decls, E_Decl); + Append_To (Decls, Decl); else - Data.E_Id := Empty; + Data.E_Id := Empty; end if; -- Generate: - -- Raised_Id : Boolean := False; Append_To (Decls, @@ -3418,8 +3458,7 @@ package body Exp_Ch7 is begin if Has_Discriminants (U_Typ) and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration - and then - Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition + and then Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition and then Present (Variant_Part (Component_List (Type_Definition (Parent (U_Typ))))) @@ -3924,15 +3963,7 @@ package body Exp_Ch7 is if Needs_Sec_Stack_Mark then Mark := Make_Temporary (Loc, 'M'); - Append_To (New_Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Mark, - Object_Definition => - New_Occurrence_Of (RTE (RE_Mark_Id), Loc), - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc)))); - + Append_To (New_Decls, Build_SS_Mark_Call (Loc, Mark)); Set_Uses_Sec_Stack (Scop, False); end if; @@ -4228,88 +4259,6 @@ package body Exp_Ch7 is end if; end Expand_N_Package_Declaration; - ------------------------------------- - -- Expand_Pragma_Initial_Condition -- - ------------------------------------- - - procedure Expand_Pragma_Initial_Condition (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Check : Node_Id; - Expr : Node_Id; - Init_Cond : Node_Id; - List : List_Id; - Pack_Id : Entity_Id; - - begin - if Nkind (N) = N_Package_Body then - Pack_Id := Corresponding_Spec (N); - - if Present (Handled_Statement_Sequence (N)) then - List := Statements (Handled_Statement_Sequence (N)); - - -- The package body lacks statements, create an empty list - - else - List := New_List; - - Set_Handled_Statement_Sequence (N, - Make_Handled_Sequence_Of_Statements (Loc, Statements => List)); - end if; - - elsif Nkind (N) = N_Package_Declaration then - Pack_Id := Defining_Entity (N); - - if Present (Visible_Declarations (Specification (N))) then - List := Visible_Declarations (Specification (N)); - - -- The package lacks visible declarations, create an empty list - - else - List := New_List; - - Set_Visible_Declarations (Specification (N), List); - end if; - - -- This routine should not be used on anything other than packages - - else - raise Program_Error; - end if; - - Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition); - - -- The caller should check whether the package is subject to pragma - -- Initial_Condition. - - pragma Assert (Present (Init_Cond)); - - Expr := - Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond))); - - -- The assertion expression was found to be illegal, do not generate the - -- runtime check as it will repeat the illegality. - - if Error_Posted (Init_Cond) or else Error_Posted (Expr) then - return; - end if; - - -- Generate: - -- pragma Check (Initial_Condition, ); - - Check := - Make_Pragma (Loc, - Chars => Name_Check, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_Initial_Condition)), - - Make_Pragma_Argument_Association (Loc, - Expression => New_Copy_Tree (Expr)))); - - Append_To (List, Check); - Analyze (Check); - end Expand_Pragma_Initial_Condition; - ----------------------------- -- Find_Node_To_Be_Wrapped -- ----------------------------- @@ -4460,25 +4409,6 @@ package body Exp_Ch7 is end loop; end Find_Node_To_Be_Wrapped; - ------------------------------------- - -- Get_Global_Pool_For_Access_Type -- - ------------------------------------- - - function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is - begin - -- Access types whose size is smaller than System.Address size can exist - -- only on VMS. We can't use the usual global pool which returns an - -- object of type Address as truncation will make it invalid. To handle - -- this case, VMS has a dedicated global pool that returns addresses - -- that fit into 32 bit accesses. - - if Opt.True_VMS_Target and then Esize (T) = 32 then - return RTE (RE_Global_Pool_32_Object); - else - return RTE (RE_Global_Pool_Object); - end if; - end Get_Global_Pool_For_Access_Type; - ---------------------------------- -- Has_New_Controlled_Component -- ---------------------------------- @@ -4551,11 +4481,17 @@ package body Exp_Ch7 is -- Insert_Actions_In_Scope_Around -- ------------------------------------ - procedure Insert_Actions_In_Scope_Around (N : Node_Id) is - Act_After : constant List_Id := - Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After); + procedure Insert_Actions_In_Scope_Around + (N : Node_Id; + Clean : Boolean; + Manage_SS : Boolean) + is Act_Before : constant List_Id := Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Before); + Act_After : constant List_Id := + Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (After); + 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 -- introduce new scopes and cause a reallocation of Scope_Stack.Table. @@ -4892,6 +4828,14 @@ package body Exp_Ch7 is Next (Stmt); end loop; + if Clean then + if Present (Prev_Fin) then + Insert_List_Before_And_Analyze (Prev_Fin, Act_Cleanup); + else + Insert_List_After_And_Analyze (Fin_Insrt, Act_Cleanup); + end if; + end if; + -- Generate: -- if Raised and then not Abort then -- Raise_From_Controlled_Operation (E); @@ -4903,86 +4847,101 @@ package body Exp_Ch7 is end if; end Process_Transient_Objects; + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; + First_Obj : Node_Id; + Last_Obj : Node_Id; + Mark_Id : Entity_Id; + Target : Node_Id; + -- Start of processing for Insert_Actions_In_Scope_Around begin - if No (Act_Before) and then No (Act_After) then + if No (Act_Before) and then No (Act_After) and then No (Act_Cleanup) then return; end if; - declare - Node_To_Wrap : constant Node_Id := Node_To_Be_Wrapped; - First_Obj : Node_Id; - Last_Obj : Node_Id; - Target : Node_Id; + -- If the node to be wrapped is the trigger of an asynchronous select, + -- it is not part of a statement list. The actions must be inserted + -- before the select itself, which is part of some list of statements. + -- Note that the triggering alternative includes the triggering + -- statement and an optional statement list. If the node to be + -- wrapped is part of that list, the normal insertion applies. - begin - -- If the node to be wrapped is the trigger of an asynchronous - -- select, it is not part of a statement list. The actions must be - -- inserted before the select itself, which is part of some list of - -- statements. Note that the triggering alternative includes the - -- triggering statement and an optional statement list. If the node - -- to be wrapped is part of that list, the normal insertion applies. - - if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative - and then not Is_List_Member (Node_To_Wrap) - then - Target := Parent (Parent (Node_To_Wrap)); - else - Target := N; - end if; + if Nkind (Parent (Node_To_Wrap)) = N_Triggering_Alternative + and then not Is_List_Member (Node_To_Wrap) + then + Target := Parent (Parent (Node_To_Wrap)); + else + Target := N; + end if; - First_Obj := Target; - Last_Obj := Target; + First_Obj := Target; + Last_Obj := Target; - -- Add all actions associated with a transient scope into the main - -- tree. There are several scenarios here: + -- Add all actions associated with a transient scope into the main tree. + -- There are several scenarios here: - -- +--- Before ----+ +----- After ---+ - -- 1) First_Obj ....... Target ........ Last_Obj + -- +--- Before ----+ +----- After ---+ + -- 1) First_Obj ....... Target ........ Last_Obj - -- 2) First_Obj ....... Target + -- 2) First_Obj ....... Target - -- 3) Target ........ Last_Obj + -- 3) Target ........ Last_Obj - if Present (Act_Before) then + -- Flag declarations are inserted before the first object - -- Flag declarations are inserted before the first object + if Present (Act_Before) then + First_Obj := First (Act_Before); + Insert_List_Before (Target, Act_Before); + end if; - First_Obj := First (Act_Before); + -- Finalization calls are inserted after the last object - Insert_List_Before (Target, Act_Before); - end if; + if Present (Act_After) then + Last_Obj := Last (Act_After); + Insert_List_After (Target, Act_After); + end if; - if Present (Act_After) then + -- Mark and release the secondary stack when the context warrants it - -- Finalization calls are inserted after the last object + if Manage_SS then + Mark_Id := Make_Temporary (Loc, 'M'); - Last_Obj := Last (Act_After); + -- Generate: + -- Mnn : constant Mark_Id := SS_Mark; - Insert_List_After (Target, Act_After); - end if; + Insert_Before_And_Analyze + (First_Obj, Build_SS_Mark_Call (Loc, Mark_Id)); - -- Check for transient controlled objects associated with Target and - -- generate the appropriate finalization actions for them. + -- Generate: + -- SS_Release (Mnn); - Process_Transient_Objects - (First_Object => First_Obj, - Last_Object => Last_Obj, - Related_Node => Target); + Insert_After_And_Analyze + (Last_Obj, Build_SS_Release_Call (Loc, Mark_Id)); + end if; - -- Reset the action lists + -- Check for transient controlled objects associated with Target and + -- generate the appropriate finalization actions for them. - if Present (Act_Before) then - Scope_Stack.Table (Scope_Stack.Last). - Actions_To_Be_Wrapped (Before) := No_List; - end if; + Process_Transient_Objects + (First_Object => First_Obj, + Last_Object => Last_Obj, + Related_Node => Target); - if Present (Act_After) then - Scope_Stack.Table (Scope_Stack.Last). - Actions_To_Be_Wrapped (After) := No_List; - end if; - end; + -- Reset the action lists + + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped (Before) := No_List; + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped (After) := No_List; + + if Clean then + Scope_Stack.Table + (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup) := No_List; + end if; end Insert_Actions_In_Scope_Around; ------------------------------ @@ -5024,7 +4983,7 @@ package body Exp_Ch7 is Utyp := Underlying_Type (Base_Type (Utyp)); Set_Assignment_OK (Ref); - -- Deal with non-tagged derivation of private views + -- Deal with untagged derivation of private views if Is_Untagged_Derivation (Typ) then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); @@ -6945,9 +6904,7 @@ package body Exp_Ch7 is -- Deep_Finalize (Obj._parent, False); - if Is_Tagged_Type (Typ) - and then Is_Derived_Type (Typ) - then + if Is_Tagged_Type (Typ) and then Is_Derived_Type (Typ) then declare Par_Typ : constant Entity_Id := Parent_Field_Type (Typ); Call : Node_Id; @@ -7002,9 +6959,7 @@ package body Exp_Ch7 is -- Finalize the object. This action must be performed first before -- all components have been finalized. - if Is_Controlled (Typ) - and then not Is_Local - then + if Is_Controlled (Typ) and then not Is_Local then declare Fin_Stmt : Node_Id; Proc : Entity_Id; @@ -7233,7 +7188,7 @@ package body Exp_Ch7 is Utyp := Underlying_Type (Base_Type (Utyp)); Set_Assignment_OK (Ref); - -- Deal with non-tagged derivation of private views. If the parent type + -- Deal with untagged derivation of private views. If the parent type -- is a protected type, Deep_Finalize is found on the corresponding -- record of the ancestor. @@ -7700,11 +7655,9 @@ package body Exp_Ch7 is Utyp := Underlying_Type (Base_Type (Utyp)); - -- Deal with non-tagged derivation of private views + -- Deal with untagged derivation of private views - if Is_Untagged_Derivation (Typ) - and then not Is_Conc - then + if Is_Untagged_Derivation (Typ) and then not Is_Conc then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); @@ -7829,7 +7782,7 @@ package body Exp_Ch7 is Utyp := Underlying_Type (Base_Type (Utyp)); - -- Deal with non-tagged derivation of private views. If the parent is + -- Deal with untagged derivation of private views. If the parent is -- now known to be protected, the finalization routine is the one -- defined on the corresponding record of the ancestor (corresponding -- records do not automatically inherit operations, but maybe they @@ -7967,9 +7920,11 @@ package body Exp_Ch7 is Set_Parent (Block, Par); -- Insert actions stuck in the transient scopes as well as all freezing - -- nodes needed by those actions. + -- nodes needed by those actions. Do not insert cleanup actions here, + -- they will be transferred to the newly created block. - Insert_Actions_In_Scope_Around (Action); + Insert_Actions_In_Scope_Around + (Action, Clean => False, Manage_SS => False); Insert := Prev (Action); if Present (Insert) then @@ -8079,7 +8034,7 @@ package body Exp_Ch7 is -- declaration into a transient block as usual case, otherwise the object -- would be itself declared in the wrong scope. Therefore, all entities (if -- any) defined in the transient block are moved to the proper enclosing - -- scope, furthermore, if they are controlled variables they are finalized + -- scope. Furthermore, if they are controlled variables they are finalized -- right after the declaration. The finalization list of the transient -- scope is defined as a renaming of the enclosing one so during their -- initialization they will be attached to the proper finalization list. @@ -8095,42 +8050,54 @@ package body Exp_Ch7 is -- [Deep_]Finalize (_v2); procedure Wrap_Transient_Declaration (N : Node_Id) is - Encl_S : Entity_Id; - S : Entity_Id; - Uses_SS : Boolean; + Curr_S : Entity_Id; + Encl_S : Entity_Id; begin - S := Current_Scope; - Encl_S := Scope (S); - - -- Insert Actions kept in the Scope stack - - Insert_Actions_In_Scope_Around (N); - - -- If the declaration is consuming some secondary stack, mark the - -- enclosing scope appropriately. - - Uses_SS := Uses_Sec_Stack (S); + Curr_S := Current_Scope; + Encl_S := Scope (Curr_S); + + -- Insert all actions inluding cleanup generated while analyzing or + -- expanding the transient context back into the tree. Manage the + -- secondary stack when the object declaration appears in a library + -- level package [body]. This is not needed for .NET/JVM as those do + -- not support the secondary stack. + + Insert_Actions_In_Scope_Around + (N => N, + Clean => True, + Manage_SS => + VM_Target = No_VM + and then Uses_Sec_Stack (Curr_S) + and then Nkind (N) = N_Object_Declaration + and then Ekind_In (Encl_S, E_Package, E_Package_Body) + and then Is_Library_Level_Entity (Encl_S)); Pop_Scope; - -- Put the local entities back in the enclosing scope, and set the - -- Is_Public flag appropriately. + -- Relocate local entities declared within the transient scope to the + -- enclosing scope. This action sets their Is_Public flag accordingly. + + Transfer_Entities (Curr_S, Encl_S); - Transfer_Entities (S, Encl_S); + -- Mark the enclosing dynamic scope to ensure that the secondary stack + -- is properly released upon exiting the said scope. This is not needed + -- for .NET/JVM as those do not support the secondary stack. - -- Mark the enclosing dynamic scope so that the sec stack will be - -- released upon its exit unless this is a function that returns on - -- the sec stack in which case this will be done by the caller. + if VM_Target = No_VM and then Uses_Sec_Stack (Curr_S) then + Curr_S := Enclosing_Dynamic_Scope (Curr_S); - if VM_Target = No_VM and then Uses_SS then - S := Enclosing_Dynamic_Scope (S); + -- Do not mark a function that returns on the secondary stack as the + -- reclamation is done by the caller. - if Ekind (S) = E_Function - and then Requires_Transient_Scope (Etype (S)) + if Ekind (Curr_S) = E_Function + and then Requires_Transient_Scope (Etype (Curr_S)) then null; + + -- Otherwise mark the enclosing dynamic scope + else - Set_Uses_Sec_Stack (S); + Set_Uses_Sec_Stack (Curr_S); Check_Restriction (No_Secondary_Stack, N); end if; end if; @@ -8153,11 +8120,11 @@ package body Exp_Ch7 is -- declare -- M : constant Mark_Id := SS_Mark; -- procedure Finalizer is ... (See Build_Finalizer) - -- + -- begin -- Temp := ; -- general case -- Temp := (if then True else False); -- boolean case - -- + -- at end -- Finalizer; -- end; diff --git a/main/gcc/ada/exp_ch7.ads b/main/gcc/ada/exp_ch7.ads index 1217e5b5f3b..ee24e6d6d55 100644 --- a/main/gcc/ada/exp_ch7.ads +++ b/main/gcc/ada/exp_ch7.ads @@ -151,11 +151,6 @@ package Exp_Ch7 is -- when pragma Restrictions (No_Finalization) applies, in which case we -- know that class-wide objects do not contain controlled parts. - function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id; - -- Return the pool id for access type T. This is generally the node - -- corresponding to System.Global_Pool.Global_Pool_Object except on - -- VMS if the access size is 32. - function Has_New_Controlled_Component (E : Entity_Id) return Boolean; -- E is a type entity. Give the same result as Has_Controlled_Component -- except for tagged extensions where the result is True only if the diff --git a/main/gcc/ada/exp_ch9.adb b/main/gcc/ada/exp_ch9.adb index 8faf3347ba3..32b3679c7db 100644 --- a/main/gcc/ada/exp_ch9.adb +++ b/main/gcc/ada/exp_ch9.adb @@ -2425,7 +2425,7 @@ package body Exp_Ch9 is -- If an inherited subprogram is implemented by a protected procedure -- or an entry, then the first parameter of the inherited subprogram - -- shall be of mode OUT or IN OUT, or access-to-variable parameter. + -- must be of mode OUT or IN OUT, or access-to-variable parameter. if Ekind (Iface_Op) = E_Procedure and then Present (Parameter_Specifications (Iface_Op_Spec)) @@ -2497,10 +2497,12 @@ package body Exp_Ch9 is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Formal))), - In_Present => In_Present (Formal), - Out_Present => Out_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; @@ -2511,8 +2513,7 @@ package body Exp_Ch9 is -- Start of processing for Build_Wrapper_Spec begin - -- There is no point in building wrappers for non-tagged concurrent - -- types. + -- No point in building wrappers for untagged concurrent types pragma Assert (Is_Tagged_Type (Obj_Typ)); @@ -4755,7 +4756,8 @@ package body Exp_Ch9 is -- case of limited type. We cannot assign it unless the -- Assignment_OK flag is set first. An out formal of an -- access type must also be initialized from the actual, - -- as stated in RM 6.4.1 (13). + -- as stated in RM 6.4.1 (13), but no constraint is applied + -- before the call. if Ekind (Formal) /= E_Out_Parameter or else Is_Access_Type (Etype (Formal)) @@ -4767,6 +4769,13 @@ package body Exp_Ch9 is Make_Assignment_Statement (Loc, Name => N_Var, Expression => Relocate_Node (Actual))); + + -- 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 + + Set_Suppress_Assignment_Checks (Last (Stats)); end if; Append (N_Node, Decls); @@ -8870,6 +8879,12 @@ package body Exp_Ch9 is -- to the internal body, for possible inlining later on. The source -- operation is invisible to the back-end and is never actually called. + function Discriminated_Size (Comp : Entity_Id) return Boolean; + -- If a component size is not static then a warning will be emitted + -- in Ravenscar or other restricted contexts. When a component is non- + -- static because of a discriminant constraint we can specialize the + -- warning by mentioning discriminants explicitly. + procedure Expand_Entry_Declaration (Comp : Entity_Id); -- Create the subprograms for the barrier and for the body, and append -- then to Entry_Bodies_Array. @@ -8897,9 +8912,66 @@ package body Exp_Ch9 is end if; end Check_Inlining; - --------------------------------- - -- Check_Static_Component_Size -- - --------------------------------- + ------------------------ + -- Discriminated_Size -- + ------------------------ + + function Discriminated_Size (Comp : Entity_Id) return Boolean is + Typ : constant Entity_Id := Etype (Comp); + Index : Node_Id; + + function Non_Static_Bound (Bound : Node_Id) return Boolean; + -- Check whether the bound of an index is non-static and does denote + -- a discriminant, in which case any protected object of the type + -- will have a non-static size. + + ---------------------- + -- Non_Static_Bound -- + ---------------------- + + function Non_Static_Bound (Bound : Node_Id) return Boolean is + begin + if Is_OK_Static_Expression (Bound) then + return False; + + elsif Is_Entity_Name (Bound) + and then Present (Discriminal_Link (Entity (Bound))) + then + return False; + + else + return True; + end if; + end Non_Static_Bound; + + -- Start of processing for Discriminated_Size + + begin + if not Is_Array_Type (Typ) then + return False; + end if; + + if Ekind (Typ) = E_Array_Subtype then + Index := First_Index (Typ); + while Present (Index) loop + if Non_Static_Bound (Low_Bound (Index)) + or else Non_Static_Bound (High_Bound (Index)) + then + return False; + end if; + + Next_Index (Index); + end loop; + + return True; + end if; + + return False; + end Discriminated_Size; + + --------------------------- + -- Static_Component_Size -- + --------------------------- function Static_Component_Size (Comp : Entity_Id) return Boolean is Typ : constant Entity_Id := Etype (Comp); @@ -9093,11 +9165,26 @@ package body Exp_Ch9 is Check_Restriction (No_Implicit_Heap_Allocations, Priv); elsif Restriction_Active (No_Implicit_Heap_Allocations) then - Error_Msg_N ("component has non-static size??", Priv); - Error_Msg_NE - ("\creation of protected object of type& will violate" - & " restriction No_Implicit_Heap_Allocations??", - Priv, Prot_Typ); + if not Discriminated_Size (Defining_Identifier (Priv)) + then + + -- Any object of the type will be non-static. + + Error_Msg_N ("component has non-static size??", Priv); + Error_Msg_NE + ("\creation of protected object of type& will" + & " violate restriction " + & "No_Implicit_Heap_Allocations??", Priv, Prot_Typ); + else + + -- 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??", + Priv, Prot_Typ); + end if; end if; end if; @@ -10539,14 +10626,13 @@ package body Exp_Ch9 is Params : constant List_Id := New_List; begin - Append ( + Append_To (Params, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Qnam, Loc), - Attribute_Name => Name_Unchecked_Access), - Params); - Append (Select_Mode, Params); - Append (New_Occurrence_Of (Ann, Loc), Params); - Append (New_Occurrence_Of (Xnam, Loc), Params); + Attribute_Name => Name_Unchecked_Access)); + Append_To (Params, Select_Mode); + Append_To (Params, New_Occurrence_Of (Ann, Loc)); + Append_To (Params, New_Occurrence_Of (Xnam, Loc)); return Make_Procedure_Call_Statement (Loc, @@ -11266,6 +11352,7 @@ package body Exp_Ch9 is Append (Cases, Stats); end; end if; + Append (End_Lab, Stats); -- Replace accept statement with appropriate block @@ -11675,7 +11762,7 @@ package body Exp_Ch9 is if Present (Taskdef) and then Has_Storage_Size_Pragma (Taskdef) and then - Is_Static_Expression + Is_OK_Static_Expression (Expression (First (Pragma_Argument_Associations (Get_Rep_Pragma (TaskId, Name_Storage_Size))))) @@ -12732,6 +12819,14 @@ package body Exp_Ch9 is Ename := Selector_Name (Prefix (Nam)); Index := First (Expressions (Nam)); end if; + + -- Through indirection, the type may actually be a limited view of a + -- concurrent type. When compiling a call, the non-limited view of the + -- type is visible. + + if From_Limited_With (Etype (Concval)) then + Set_Etype (Concval, Non_Limited_View (Etype (Concval))); + end if; end Extract_Entry; ------------------- diff --git a/main/gcc/ada/exp_ch9.ads b/main/gcc/ada/exp_ch9.ads index abbd4e72fba..d9fa7d6d7fb 100644 --- a/main/gcc/ada/exp_ch9.ads +++ b/main/gcc/ada/exp_ch9.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -173,7 +173,8 @@ package Exp_Ch9 is -- allocated aggregates with default initialized components. Init_Stmts -- contains the list of statements required to initialize the allocated -- aggregate. It replaces the call to Init (Args) done by - -- Build_Task_Allocate_Block. + -- Build_Task_Allocate_Block. Also used to expand allocators containing + -- build-in-place function calls. function Build_Wrapper_Spec (Subp_Id : Entity_Id; diff --git a/main/gcc/ada/exp_dbug.adb b/main/gcc/ada/exp_dbug.adb index cbd4c55d949..c025f05f378 100644 --- a/main/gcc/ada/exp_dbug.adb +++ b/main/gcc/ada/exp_dbug.adb @@ -306,6 +306,16 @@ package body Exp_Dbug is Obj : Entity_Id; Res : Node_Id; + Enable : Boolean := Nkind (N) = N_Package_Renaming_Declaration; + -- By default, we do not generate an encoding for renaming. This is + -- however done (in which case this is set to True) in a few cases: + -- - when a package is renamed, + -- - when the renaming involves a packed array, + -- - when the renaming involves a packed record. + + procedure Enable_If_Packed_Array (N : Node_Id); + -- Enable encoding generation if N is a packed array + function Output_Subscript (N : Node_Id; S : String) return Boolean; -- Outputs a single subscript value as ?nnn (subscript is compile time -- known value with value nnn) or as ?e (subscript is local constant @@ -314,6 +324,18 @@ package body Exp_Dbug is -- output in one of these two forms. The result is prepended to the -- name stored in Name_Buffer. + ---------------------------- + -- Enable_If_Packed_Array -- + ---------------------------- + + procedure Enable_If_Packed_Array (N : Node_Id) is + T : constant Entity_Id := Etype (N); + begin + Enable := + Enable or else (Ekind (T) in Array_Kind + and then Present (Packed_Array_Impl_Type (T))); + end Enable_If_Packed_Array; + ---------------------- -- Output_Subscript -- ---------------------- @@ -372,6 +394,7 @@ package body Exp_Dbug is exit; when N_Selected_Component => + Enable := Enable or else Is_Packed (Etype (Prefix (Ren))); Prepend_String_To_Buffer (Get_Name_String (Chars (Selector_Name (Ren)))); Prepend_String_To_Buffer ("XR"); @@ -379,9 +402,12 @@ package body Exp_Dbug is when N_Indexed_Component => declare - X : Node_Id := Last (Expressions (Ren)); + X : Node_Id; begin + Enable_If_Packed_Array (Prefix (Ren)); + + X := Last (Expressions (Ren)); while Present (X) loop if not Output_Subscript (X, "XS") then Set_Materialize_Entity (Ent); @@ -395,7 +421,7 @@ package body Exp_Dbug is Ren := Prefix (Ren); when N_Slice => - + Enable_If_Packed_Array (Prefix (Ren)); Typ := Etype (First_Index (Etype (Nam))); if not Output_Subscript (Type_High_Bound (Typ), "XS") then @@ -422,6 +448,13 @@ package body Exp_Dbug is end case; end loop; + -- If we found no reason here to emit an encoding, stop now + + if not Enable then + Set_Materialize_Entity (Ent); + return Empty; + end if; + Prepend_String_To_Buffer ("___XE"); -- Include the designation of the form of renaming @@ -479,6 +512,13 @@ package body Exp_Dbug is Set_Debug_Info_Needed (Obj); + -- The renamed entity may be a temporary, e.g. the result of an + -- implicit dereference in an iterator. Indicate that the temporary + -- itself requires debug information. If the renamed entity comes + -- from source this is a no-op. + + Set_Debug_Info_Needed (Entity (Ren)); + -- Mark the object as internal so that it won't be initialized when -- pragma Initialize_Scalars or Normalize_Scalars is in use. @@ -564,20 +604,6 @@ package body Exp_Dbug is Add_Real_To_Buffer (Small_Value (E)); end if; - -- Vax floating-point case - - elsif Vax_Float (E) then - if Digits_Value (Base_Type (E)) = 6 then - Get_External_Name (E, True, "XFF"); - - elsif Digits_Value (Base_Type (E)) = 9 then - Get_External_Name (E, True, "XFF"); - - else - pragma Assert (Digits_Value (Base_Type (E)) = 15); - Get_External_Name (E, True, "XFG"); - end if; - -- Discrete case where bounds do not match size elsif Is_Discrete_Type (E) @@ -1096,7 +1122,8 @@ package body Exp_Dbug is function Qualify_Needed (S : Entity_Id) return Boolean; -- Given a scope, determines if the scope is to be included in the - -- fully qualified name, True if so, False if not. + -- fully qualified name, True if so, False if not. Blocks and loops + -- are excluded from a qualified name. procedure Set_BNPE_Suffix (E : Entity_Id); -- Recursive routine to append the BNPE qualification suffix. Works @@ -1211,6 +1238,7 @@ package body Exp_Dbug is return Is_Subprogram (Ent) or else Ekind (Ent) = E_Subprogram_Body or else (Ekind (S) /= E_Block + and then Ekind (S) /= E_Loop and then not Is_Dynamic_Scope (S)); end if; end Qualify_Needed; diff --git a/main/gcc/ada/exp_dbug.ads b/main/gcc/ada/exp_dbug.ads index c687cdde9d5..eefc9c9c637 100644 --- a/main/gcc/ada/exp_dbug.ads +++ b/main/gcc/ada/exp_dbug.ads @@ -540,31 +540,6 @@ package Exp_Dbug is -- delta. In this case, the first nn/dd rational value is for delta, -- and the second value is for small. - ------------------------------ - -- VAX Floating-Point Types -- - ------------------------------ - - -- Vax floating-point types are represented at run time as integer - -- types, which are treated specially by the code generator. Their - -- type names are encoded with the following suffix: - - -- typ___XFF - -- typ___XFD - -- typ___XFG - - -- representing the Vax F Float, D Float, and G Float types. The - -- debugger must treat these specially. In particular, printing these - -- values can be achieved using the debug procedures that are provided - -- in package System.Vax_Float_Operations: - - -- procedure Debug_Output_D (Arg : D); - -- procedure Debug_Output_F (Arg : F); - -- procedure Debug_Output_G (Arg : G); - - -- These three procedures take a Vax floating-point argument, and - -- output a corresponding decimal representation to standard output - -- with no terminating line return. - -------------------- -- Discrete Types -- -------------------- diff --git a/main/gcc/ada/exp_disp.adb b/main/gcc/ada/exp_disp.adb index e1032bbf4c1..99105e0ea4f 100644 --- a/main/gcc/ada/exp_disp.adb +++ b/main/gcc/ada/exp_disp.adb @@ -75,12 +75,6 @@ package body Exp_Disp is -- Ada 2005 (AI-251): Returns the fixed position in the dispatch table -- of the default primitive operations. - function Find_Specific_Type (CW : Entity_Id) return Entity_Id; - -- Find specific type of a class-wide type, and handle the case of an - -- incomplete type coming either from a limited_with clause or from an - -- incomplete type declaration. Shouldn't this be in Sem_Util? It seems - -- like a general purpose semantic routine ??? - function Has_DT (Typ : Entity_Id) return Boolean; pragma Inline (Has_DT); -- Returns true if we generate a dispatch table for tagged type Typ @@ -1191,6 +1185,19 @@ package body Exp_Disp is end if; return; + + -- A static conversion to an interface type that is not classwide is + -- curious but legal if the interface operation is a null procedure. + -- If the operation is abstract it will be rejected later. + + elsif Is_Static + and then Is_Interface (Etype (N)) + and then not Is_Class_Wide_Type (Etype (N)) + and then Comes_From_Source (N) + then + Rewrite (N, Unchecked_Convert_To (Etype (N), N)); + Analyze (N); + return; end if; if not Is_Static then @@ -1974,25 +1981,6 @@ package body Exp_Disp is end if; end Expand_Interface_Thunk; - ------------------------ - -- Find_Specific_Type -- - ------------------------ - - function Find_Specific_Type (CW : Entity_Id) return Entity_Id is - Typ : Entity_Id := Root_Type (CW); - - begin - if Ekind (Typ) = E_Incomplete_Type then - if From_Limited_With (Typ) then - Typ := Non_Limited_View (Typ); - else - Typ := Full_View (Typ); - end if; - end if; - - return Typ; - end Find_Specific_Type; - -------------------------- -- Has_CPP_Constructors -- -------------------------- @@ -3672,18 +3660,17 @@ package body Exp_Disp is (Subp : Entity_Id; Tagged_Type : Entity_Id; Typ : Entity_Id); - -- Verify that all non-tagged types in the profile of a subprogram - -- are frozen at the point the subprogram is frozen. This enforces - -- the rule on RM 13.14 (14) as modified by AI05-019. At the point a - -- subprogram is frozen, enough must be known about it to build the - -- activation record for it, which requires at least that the size of - -- all parameters be known. Controlling arguments are by-reference, - -- and therefore the rule only applies to non-tagged types. - -- Typical violation of the rule involves an object declaration that - -- freezes a tagged type, when one of its primitive operations has a - -- type in its profile whose full view has not been analyzed yet. - -- More complex cases involve composite types that have one private - -- unfrozen subcomponent. + -- Verify that all untagged types in the profile of a subprogram are + -- frozen at the point the subprogram is frozen. This enforces the rule + -- on RM 13.14 (14) as modified by AI05-019. At the point a subprogram + -- is frozen, enough must be known about it to build the activation + -- record for it, which requires at least that the size of all + -- parameters be known. Controlling arguments are by-reference, + -- and therefore the rule only applies to untagged types. Typical + -- violation of the rule involves an object declaration that freezes a + -- tagged type, when one of its primitive operations has a type in its + -- profile whose full view has not been analyzed yet. More complex cases + -- involve composite types that have one private unfrozen subcomponent. procedure Export_DT (Typ : Entity_Id; DT : Entity_Id; Index : Nat := 0); -- Export the dispatch table DT of tagged type Typ. Required to generate @@ -8438,10 +8425,10 @@ package body Exp_Disp is Make_Defining_Identifier (Loc, Chars => Make_Init_Proc_Name (Typ)); - -- Case 1: Constructor of non-tagged type + -- Case 1: Constructor of untagged type -- If the C++ class has no virtual methods then the matching Ada - -- type is a non-tagged record type. In such case there is no need + -- type is an untagged record type. In such case there is no need -- to generate a wrapper of the C++ constructor because the _tag -- component is not available. diff --git a/main/gcc/ada/exp_dist.adb b/main/gcc/ada/exp_dist.adb index 78778a07a72..74f9055ba1f 100644 --- a/main/gcc/ada/exp_dist.adb +++ b/main/gcc/ada/exp_dist.adb @@ -528,23 +528,23 @@ package body Exp_Dist is RACW_Type : Entity_Id := Empty; Nod : Node_Id); -- Build calling stubs for general purpose. The parameters are: - -- Decls : a place to put declarations - -- Statements : a place to put statements - -- Target : PCS-specific target information (see details - -- in RPC_Target declaration). - -- Subprogram_Id : a node containing the subprogram ID + -- Decls : A place to put declarations + -- Statements : A place to put statements + -- Target : PCS-specific target information (see details in + -- RPC_Target declaration). + -- Subprogram_Id : A node containing the subprogram ID -- Asynchronous : True if an APC must be made instead of an RPC. -- The value needs not be supplied if one of the -- Is_Known_... is True. -- Is_Known_Async... : True if we know that this is asynchronous -- Is_Known_Non_A... : True if we know that this is not asynchronous - -- Spec : a node with a Parameter_Specifications and - -- a Result_Definition if applicable - -- Stub_Type : in case of RACW stubs, parameters of type access - -- to Stub_Type will be marshalled using the + -- Spec : Node with a Parameter_Specifications and a + -- Result_Definition if applicable + -- Stub_Type : For case of RACW stubs, parameters of type access + -- to Stub_Type will be marshalled using the address -- address of the object (the addr field) rather -- than using the 'Write on the stub itself - -- Nod : used to provide sloc for generated code + -- Nod : Used to provide sloc for generated code function Specific_Build_Stub_Target (Loc : Source_Ptr; @@ -9465,7 +9465,7 @@ package body Exp_Dist is elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then - -- Non-tagged derived type: convert to root type + -- Untagged derived type: convert to root type declare Rt_Type : constant Entity_Id := Root_Type (Typ); @@ -9480,7 +9480,7 @@ package body Exp_Dist is elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then - -- Non-tagged record type + -- Untagged record type if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then declare diff --git a/main/gcc/ada/exp_intr.adb b/main/gcc/ada/exp_intr.adb index a4a498904f4..465c8b2f91d 100644 --- a/main/gcc/ada/exp_intr.adb +++ b/main/gcc/ada/exp_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 +109,12 @@ package body Exp_Intr is 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 that is the name of source file - -- Name_Line - expand integer line number - -- Name_Source_Location - expand string of form file:line - -- Name_Enclosing_Entity - expand string with name of enclosing entity + -- 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 --------------------------------- -- Expand_Binary_Operator_Call -- @@ -557,7 +559,9 @@ package body Exp_Intr is elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location, - Name_Enclosing_Entity) + Name_Enclosing_Entity, + Name_Compilation_Date, + Name_Compilation_Time) then Expand_Source_Info (N, Nam); @@ -806,6 +810,35 @@ package body Exp_Intr is 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; @@ -914,6 +947,7 @@ package body Exp_Intr is Finalizer_Data : Finalization_Exception_Data; Blk : Node_Id := Empty; + Blk_Id : Entity_Id; Deref : Node_Id; Final_Code : List_Id; Free_Arg : Node_Id; @@ -926,6 +960,10 @@ package body Exp_Intr is -- that we analyze some generated statements before properly attaching -- them to the tree, and that can disturb current value settings. + Dummy : Entity_Id; + -- This variable captures an unused dummy internal entity, see the + -- comment associated with its use. + begin -- Nothing to do if we know the argument is null @@ -1007,8 +1045,7 @@ package body Exp_Intr is -- protected by an abort defer/undefer pair. if Abort_Allowed then - Prepend_To (Final_Code, - Build_Runtime_Call (Loc, RE_Abort_Defer)); + Prepend_To (Final_Code, Build_Runtime_Call (Loc, RE_Abort_Defer)); Blk := Make_Block_Statement (Loc, Handled_Statement_Sequence => @@ -1016,9 +1053,15 @@ package body Exp_Intr is Statements => Final_Code, At_End_Proc => New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc))); + Add_Block_Identifier (Blk, Blk_Id); Append (Blk, Stmts); + else + -- Generate a dummy entity to ensure that the internal symbols are + -- in sync when a unit is compiled with and without aborts. + + Dummy := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B'); Append_List_To (Stmts, Final_Code); end if; end if; @@ -1063,9 +1106,11 @@ package body Exp_Intr is end if; end if; - -- Normal processing for non-controlled types + -- Normal processing for non-controlled types. The argument to free is + -- a renaming rather than a constant to ensure that the original context + -- is always set to null after the deallocation takes place. - Free_Arg := Duplicate_Subexpr_No_Checks (Arg); + Free_Arg := Duplicate_Subexpr_No_Checks (Arg, Renaming_Req => True); Free_Node := Make_Free_Statement (Loc, Empty); Append_To (Stmts, Free_Node); Set_Storage_Pool (Free_Node, Pool); diff --git a/main/gcc/ada/exp_intr.ads b/main/gcc/ada/exp_intr.ads index a9d8a391909..1285f4ffc07 100644 --- a/main/gcc/ada/exp_intr.ads +++ b/main/gcc/ada/exp_intr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 @@ package Exp_Intr is procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id); -- N is either a function call node, a procedure call statement node, or -- an operator where the corresponding subprogram is intrinsic (i.e. was - -- the subject of a Import or Interface pragma specifying the subprogram - -- as intrinsic. The effect is to replace the call with appropriate - -- specialized nodes. The second argument is the entity for the + -- the subject of an Import or Interface pragma specifying the subprogram + -- as intrinsic. The effect is to replace the call with appropriate + -- specialized nodes. The second argument is the entity for the -- subprogram spec. end Exp_Intr; diff --git a/main/gcc/ada/exp_pakd.adb b/main/gcc/ada/exp_pakd.adb index 7455e25eeb2..6ff75278d97 100644 --- a/main/gcc/ada/exp_pakd.adb +++ b/main/gcc/ada/exp_pakd.adb @@ -796,9 +796,9 @@ package body Exp_Pakd is end if; end Convert_To_PAT_Type; - ------------------------------ + ----------------------------------- -- Create_Packed_Array_Impl_Type -- - ------------------------------ + ----------------------------------- procedure Create_Packed_Array_Impl_Type (Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (Typ); @@ -1469,6 +1469,10 @@ package body Exp_Pakd is -- out-of-range value by design. Compile this value without checks, -- because a call to the array init_proc must not raise an exception. + -- Condition is not consistent with description above, Within_Init_Proc + -- is True also when we are building the IP for a record or protected + -- type that has a packed array component??? + if Within_Init_Proc and then Initialize_Scalars then @@ -1723,6 +1727,7 @@ package body Exp_Pakd is Set_nn : Entity_Id; Subscr : Node_Id; Atyp : Entity_Id; + Rev_SSO : Node_Id; begin if No (Bits_nn) then @@ -1748,6 +1753,12 @@ package body Exp_Pakd is Atyp := Etype (Obj); Compute_Linear_Subscript (Atyp, Lhs, Subscr); + -- Set indication of whether the packed array has reverse SSO + + Rev_SSO := + New_Occurrence_Of + (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc); + -- Below we must make the assumption that Obj is -- at least byte aligned, since otherwise its address -- cannot be taken. The assumption holds since the @@ -1763,8 +1774,8 @@ package body Exp_Pakd is Prefix => Obj, Attribute_Name => Name_Address), Subscr, - Unchecked_Convert_To (Bits_nn, - Convert_To (Ctyp, Rhs))))); + Unchecked_Convert_To (Bits_nn, Convert_To (Ctyp, Rhs)), + Rev_SSO))); end; end if; @@ -2123,8 +2134,11 @@ package body Exp_Pakd is -- where Subscr is the computed linear subscript declare - Get_nn : Entity_Id; - Subscr : Node_Id; + Get_nn : Entity_Id; + Subscr : Node_Id; + Rev_SSO : constant Node_Id := + New_Occurrence_Of + (Boolean_Literals (Reverse_Storage_Order (Atyp)), Loc); begin -- Acquire proper Get entity. We use the aligned or unaligned @@ -2154,12 +2168,12 @@ package body Exp_Pakd is Make_Attribute_Reference (Loc, Prefix => Obj, Attribute_Name => Name_Address), - Subscr)))); + Subscr, + Rev_SSO)))); end; end if; Analyze_And_Resolve (N, Ctyp, Suppress => All_Checks); - end Expand_Packed_Element_Reference; ---------------------- diff --git a/main/gcc/ada/exp_prag.adb b/main/gcc/ada/exp_prag.adb index fef09c4d12d..ae97013a5c5 100644 --- a/main/gcc/ada/exp_prag.adb +++ b/main/gcc/ada/exp_prag.adb @@ -41,14 +41,12 @@ with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch8; use Sem_Ch8; -with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; with Stand; use Stand; -with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -68,7 +66,6 @@ package body Exp_Prag is procedure Expand_Pragma_Check (N : Node_Id); procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import_Or_Interface (N : Node_Id); - procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); procedure Expand_Pragma_Loop_Variant (N : Node_Id); @@ -440,6 +437,9 @@ package body Exp_Prag is -- Generate a temporary to capture the value of the prefix: -- Temp : ; + -- 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, @@ -448,7 +448,7 @@ package body Exp_Prag is New_Occurrence_Of (Etype (Pref), Loc)); Set_No_Initialization (Decl); - Append_To (Decls, Decl); + Prepend_To (Decls, Decl); -- Evaluate the prefix, generate: -- Temp := ; @@ -815,15 +815,9 @@ package body Exp_Prag is when Pragma_Common_Object => Expand_Pragma_Common_Object (N); - when Pragma_Export_Exception => - Expand_Pragma_Import_Export_Exception (N); - when Pragma_Import => Expand_Pragma_Import_Or_Interface (N); - when Pragma_Import_Exception => - Expand_Pragma_Import_Export_Exception (N); - when Pragma_Inspection_Point => Expand_Pragma_Inspection_Point (N); @@ -990,8 +984,8 @@ package body Exp_Prag is -- Case where we generate a direct raise - if ((Debug_Flag_Dot_G or else - Restriction_Active (No_Exception_Propagation)) + if ((Debug_Flag_Dot_G + or else Restriction_Active (No_Exception_Propagation)) and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N))) or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N))) then @@ -1073,12 +1067,10 @@ package body Exp_Prag is Rewrite (N, Make_If_Statement (Loc, - Condition => - Make_Op_Not (Loc, - Right_Opnd => Cond), + Condition => Make_Op_Not (Loc, Right_Opnd => Cond), Then_Statements => New_List ( Make_Procedure_Call_Statement (Loc, - Name => + Name => New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc), Parameter_Associations => New_List (Relocate_Node (Msg)))))); end if; @@ -1146,15 +1138,13 @@ package body Exp_Prag is Set_All_Upper_Case; Psect := - Make_String_Literal (Eloc, - Strval => String_From_Name_Buffer); + Make_String_Literal (Eloc, Strval => String_From_Name_Buffer); else Get_Name_String (Chars (Internal)); Set_All_Upper_Case; Psect := - Make_String_Literal (Iloc, - Strval => String_From_Name_Buffer); + Make_String_Literal (Iloc, Strval => String_From_Name_Buffer); end if; Ploc := Sloc (Psect); @@ -1162,18 +1152,16 @@ package body Exp_Prag is -- Insert the pragma Insert_After_And_Analyze (N, - Make_Pragma (Loc, - Chars => Name_Machine_Attribute, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Iloc, - Expression => New_Copy_Tree (Internal)), - Make_Pragma_Argument_Association (Eloc, - Expression => - Make_String_Literal (Sloc => Ploc, - Strval => "common_object")), - Make_Pragma_Argument_Association (Ploc, - Expression => New_Copy_Tree (Psect))))); - + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, Strval => "common_object")), + Make_Pragma_Argument_Association (Ploc, + Expression => New_Copy_Tree (Psect))))); end Expand_Pragma_Common_Object; --------------------------------------- @@ -1294,175 +1282,87 @@ package body Exp_Prag is end if; end Expand_Pragma_Import_Or_Interface; - ------------------------------------------- - -- Expand_Pragma_Import_Export_Exception -- - ------------------------------------------- + ------------------------------------- + -- Expand_Pragma_Initial_Condition -- + ------------------------------------- - -- For a VMS exception fix up the language field with "VMS" - -- instead of "Ada" (gigi needs this), create a constant that will be the - -- value of the VMS condition code and stuff the Interface_Name field - -- with the unexpanded name of the exception (if not already set). - -- For a Ada exception, just stuff the Interface_Name field - -- with the unexpanded name of the exception (if not already set). + procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is + 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; - procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is begin - -- This pragma is only effective on OpenVMS systems, it was ignored - -- on non-VMS systems, and we need to ignore it here as well. + if Nkind (Spec_Or_Body) = N_Package_Body then + Pack_Id := Corresponding_Spec (Spec_Or_Body); - if not OpenVMS_On_Target then - return; - end if; + if Present (Handled_Statement_Sequence (Spec_Or_Body)) then + List := Statements (Handled_Statement_Sequence (Spec_Or_Body)); - declare - Id : constant Entity_Id := Entity (Arg1 (N)); - Call : constant Node_Id := Register_Exception_Call (Id); - Loc : constant Source_Ptr := Sloc (N); + -- The package body lacks statements, create an empty list - begin - if Present (Call) then - declare - Excep_Internal : constant Node_Id := Make_Temporary (Loc, 'V'); - Export_Pragma : Node_Id; - Excep_Alias : Node_Id; - Excep_Object : Node_Id; - Excep_Image : String_Id; - Exdata : List_Id; - Lang_Char : Node_Id; - Code : Node_Id; + else + List := New_List; - begin - -- Compute the symbol for the code of the condition + Set_Handled_Statement_Sequence (Spec_Or_Body, + Make_Handled_Sequence_Of_Statements (Loc, Statements => List)); + end if; - if Present (Interface_Name (Id)) then - Excep_Image := Strval (Interface_Name (Id)); - else - Get_Name_String (Chars (Id)); - Set_All_Upper_Case; - Excep_Image := String_From_Name_Buffer; - end if; + elsif Nkind (Spec_Or_Body) = N_Package_Declaration then + Pack_Id := Defining_Entity (Spec_Or_Body); - Exdata := Component_Associations (Expression (Parent (Id))); + if Present (Visible_Declarations (Specification (Spec_Or_Body))) then + List := Visible_Declarations (Specification (Spec_Or_Body)); - if Is_VMS_Exception (Id) then - Lang_Char := Next (First (Exdata)); - - -- Change the one-character language designator to 'V' - - Rewrite (Expression (Lang_Char), - Make_Character_Literal (Loc, - Chars => Name_uV, - Char_Literal_Value => - UI_From_Int (Character'Pos ('V')))); - Analyze (Expression (Lang_Char)); - - if Exception_Code (Id) /= No_Uint then - - -- The code for the exception is present. Create a linker - -- alias to define the symbol. - - Code := - Unchecked_Convert_To (RTE (RE_Address), - Make_Integer_Literal (Loc, - Intval => Exception_Code (Id))); - - -- Declare a dummy object - - Excep_Object := - Make_Object_Declaration (Loc, - Defining_Identifier => Excep_Internal, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc)); - - Insert_Action (N, Excep_Object); - Analyze (Excep_Object); - - -- Clear severity bits - - Start_String; - Store_String_Int - (UI_To_Int (Exception_Code (Id)) / 8 * 8); - - -- Insert a pragma Linker_Alias to set the value of the - -- dummy object symbol. - - Excep_Alias := - Make_Pragma (Loc, - Chars => Name_Linker_Alias, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => - New_Occurrence_Of (Excep_Internal, Loc)), - - Make_Pragma_Argument_Association (Loc, - Expression => - Make_String_Literal (Loc, End_String)))); - - Insert_Action (N, Excep_Alias); - Analyze (Excep_Alias); - - -- Insert a pragma Export to give a Linker_Name to the - -- dummy object. - - Export_Pragma := - Make_Pragma (Loc, - Chars => Name_Export, - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Name_C)), - - Make_Pragma_Argument_Association (Loc, - Expression => - New_Occurrence_Of (Excep_Internal, Loc)), - - Make_Pragma_Argument_Association (Loc, - Expression => - Make_String_Literal (Loc, Excep_Image)), - - Make_Pragma_Argument_Association (Loc, - Expression => - Make_String_Literal (Loc, Excep_Image)))); - - Insert_Action (N, Export_Pragma); - Analyze (Export_Pragma); - - else - Code := - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Import_Address), Loc), - Parameter_Associations => New_List - (Make_String_Literal (Loc, - Strval => Excep_Image))); - end if; - - -- Generate the call to Register_VMS_Exception - - Rewrite (Call, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of - (RTE (RE_Register_VMS_Exception), Loc), - Parameter_Associations => New_List ( - Code, - Unchecked_Convert_To (RTE (RE_Exception_Data_Ptr), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Id, Loc), - Attribute_Name => Name_Unrestricted_Access))))); - - Analyze_And_Resolve (Code, RTE (RE_Address)); - Analyze (Call); - end if; + -- The package lacks visible declarations, create an empty list - if No (Interface_Name (Id)) then - Set_Interface_Name (Id, - Make_String_Literal - (Sloc => Loc, - Strval => Excep_Image)); - end if; - end; + else + List := New_List; + + Set_Visible_Declarations (Specification (Spec_Or_Body), List); end if; - end; - end Expand_Pragma_Import_Export_Exception; + + -- This routine should not be used on anything other than packages + + else + raise Program_Error; + end if; + + Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition); + + -- The caller should check whether the package is subject to pragma + -- Initial_Condition. + + pragma Assert (Present (Init_Cond)); + + Expr := + Get_Pragma_Arg (First (Pragma_Argument_Associations (Init_Cond))); + + -- The assertion expression was found to be illegal, do not generate the + -- runtime check as it will repeat the illegality. + + if Error_Posted (Init_Cond) or else Error_Posted (Expr) then + return; + end if; + + -- Generate: + -- pragma Check (Initial_Condition, ); + + Check := + Make_Pragma (Loc, + Chars => Name_Check, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Name_Initial_Condition)), + + Make_Pragma_Argument_Association (Loc, + Expression => New_Copy_Tree (Expr)))); + + Append_To (List, Check); + Analyze (Check); + end Expand_Pragma_Initial_Condition; ------------------------------------ -- Expand_Pragma_Inspection_Point -- diff --git a/main/gcc/ada/exp_prag.ads b/main/gcc/ada/exp_prag.ads index 681f1160dea..d1ddfea177e 100644 --- a/main/gcc/ada/exp_prag.ads +++ b/main/gcc/ada/exp_prag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,4 +42,15 @@ package Exp_Prag is -- Subp_Id's body. All generated code is added to list Stmts. If Stmts is -- No_List on entry, a new list is created. + procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id); + -- Generate a runtime check needed to verify the assumption of introduced + -- by pragma Initial_Condition. Spec_Or_Body denotes the spec or body of + -- the package where the pragma appears. The check is inserted according + -- to the following precedence rules: + -- 1) If the package has a body with a statement sequence, the check is + -- inserted at the end of the statments. + -- 2) If the package has a body, the check is inserted at the end of the + -- body declarations. + -- 3) The check is inserted at the end of the visible declarations. + end Exp_Prag; diff --git a/main/gcc/ada/exp_smem.adb b/main/gcc/ada/exp_smem.adb index 819de1d9e5f..387b32f71ea 100644 --- a/main/gcc/ada/exp_smem.adb +++ b/main/gcc/ada/exp_smem.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Einfo; use Einfo; +with Elists; use Elists; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; with Exp_Tss; use Exp_Tss; @@ -133,61 +134,119 @@ package body Exp_Smem is Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); Vnm : String_Id; Vid : Entity_Id; + Vde : Node_Id; Aft : constant List_Id := New_List; + In_Transient : constant Boolean := Scope_Is_Transient; + + function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id; + -- Return a procedure call statement for lock proc RTE + + -------------------------------- + -- Build_Shared_Var_Lock_Call -- + -------------------------------- + + function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id is + begin + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Vid, Loc))); + end Build_Shared_Var_Lock_Call; + + -- Start of processing for Add_Shared_Var_Lock_Procs + begin + -- Discussion of transient scopes: we need to have a transient scope + -- to hold the required lock/unlock actions. Either the current scope + -- is transient, in which case we reuse it, or we establish a new + -- transient scope. If this is a function call with unconstrained + -- return type, we can't introduce a transient scope here (because + -- Wrap_Transient_Expression would need to declare a temporary with + -- the unconstrained type outside of the transient block), but in that + -- case we know that we have already established one at an outer level + -- for secondary stack management purposes. + + -- If the lock/read/write/unlock actions for this object have already + -- been emitted in the current scope, no need to perform them anew. + + if In_Transient + and then Contains (Scope_Stack.Table (Scope_Stack.Last) + .Locked_Shared_Objects, + Obj) + then + return; + end if; + Build_Full_Name (Obj, Vnm); - -- Create constant string. Note that this must be done prior to - -- establishing the transient scope, as the finalizer needs to have - -- access to this object. + -- Declare a constant string to hold the name of the shared object. + -- Note that this must occur outside of the transient scope, as the + -- scope's finalizer needs to have access to this object. Also, it + -- appears that GIGI does not support elaborating string literal + -- subtypes in transient scopes. Vid := Make_Temporary (Loc, 'N', Obj); - Insert_Action (N, + Vde := Make_Object_Declaration (Loc, Defining_Identifier => Vid, Constant_Present => True, Object_Definition => New_Occurrence_Of (Standard_String, Loc), - Expression => Make_String_Literal (Loc, Vnm))); + Expression => Make_String_Literal (Loc, Vnm)); + + -- Already in a transient scope. Make sure that we insert Vde outside + -- that scope. - -- Now set up a transient scope around the call, which will hold the - -- required lock/unlock actions. + if In_Transient then + Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde); - Establish_Transient_Scope (N, Sec_Stack => False); + -- Not in a transient scope yet: insert Vde as an action on N prior to + -- establishing one. + + else + Insert_Action (N, Vde); + Establish_Transient_Scope (N, Sec_Stack => False); + end if; + + -- Mark object as locked in the current (transient) scope + + Append_New_Elmt + (Obj, + To => Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects); -- First insert the Lock call before - Insert_Action (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc), - Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc)))); + Insert_Action (N, Build_Shared_Var_Lock_Call (RE_Shared_Var_Lock)); -- Now, right after the Lock, insert a call to read the object - Insert_Action (N, - Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); + Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); - -- Now for a procedure call, but not a function call, insert the - -- call to write the object just before the unlock. + -- For a procedure call only, insert the call to write the object prior + -- to unlocking. if Nkind (N) = N_Procedure_Call_Statement then - Append_To (Aft, - Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); + Append_To (Aft, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); end if; - -- Finally insert the Unlock call after + -- Finally insert the Unlock call + + Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock)); - Append_To (Aft, - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc), - Parameter_Associations => New_List (New_Occurrence_Of (Vid, Loc)))); + -- Store cleanup actions in transient scope Store_Cleanup_Actions_In_Scope (Aft); - if Nkind (N) = N_Procedure_Call_Statement then - Wrap_Transient_Statement (N); - else - Wrap_Transient_Expression (N); + -- If we have established a transient scope here, wrap it now + + if not In_Transient then + if Nkind (N) = N_Procedure_Call_Statement then + Wrap_Transient_Statement (N); + else + Wrap_Transient_Expression (N); + end if; end if; end Add_Shared_Var_Lock_Procs; diff --git a/main/gcc/ada/exp_strm.adb b/main/gcc/ada/exp_strm.adb index 1ffe9a51d97..dfb5f0dd2e0 100644 --- a/main/gcc/ada/exp_strm.adb +++ b/main/gcc/ada/exp_strm.adb @@ -131,9 +131,9 @@ package body Exp_Strm is -- return V; -- end typSI[_nnn] - -- Note: the suffix [_nnn] is present for non-tagged types, where we - -- generate a local subprogram at the point of the occurrence of the - -- attribute reference, so the name must be unique. + -- Note: the suffix [_nnn] is present for untagged types, where we generate + -- a local subprogram at the point of the occurrence of the attribute + -- reference, so the name must be unique. procedure Build_Array_Input_Function (Loc : Source_Ptr; @@ -155,7 +155,6 @@ package body Exp_Strm is Decls := New_List; Ranges := New_List; Indx := First_Index (Typ); - for J in 1 .. Dim loop Lnam := New_External_Name ('L', J); Hnam := New_External_Name ('H', J); @@ -435,7 +434,6 @@ package body Exp_Strm is Pnam : out Entity_Id) is Loc : constant Source_Ptr := Sloc (Nod); - begin Pnam := Make_Defining_Identifier (Loc, @@ -636,6 +634,7 @@ package body Exp_Strm is Relocate_Node (Strm)))); Set_Do_Range_Check (Res); + if Base_Type (P_Type) /= Base_Type (U_Type) then Res := Unchecked_Convert_To (Base_Type (P_Type), Res); end if; diff --git a/main/gcc/ada/exp_util.adb b/main/gcc/ada/exp_util.adb index d4b9604ae2c..d5d269c28ca 100644 --- a/main/gcc/ada/exp_util.adb +++ b/main/gcc/ada/exp_util.adb @@ -461,7 +461,7 @@ package body Exp_Util is Utyp := Underlying_Type (Base_Type (Utyp)); - -- Deal with non-tagged derivation of private views. If the parent is + -- Deal with untagged derivation of private views. If the parent is -- now known to be protected, the finalization routine is the one -- defined on the corresponding record of the ancestor (corresponding -- records do not automatically inherit operations, but maybe they @@ -786,7 +786,7 @@ package body Exp_Util is if Is_Allocate or else not Is_Class_Wide_Type (Desig_Typ) then Append_To (Actuals, New_Occurrence_Of (Alig_Id, Loc)); - -- For deallocation of class wide types we obtain the value of + -- 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. @@ -1013,6 +1013,49 @@ package body Exp_Util is end if; end Build_Runtime_Call; + ------------------------ + -- Build_SS_Mark_Call -- + ------------------------ + + function Build_SS_Mark_Call + (Loc : Source_Ptr; + Mark : Entity_Id) return Node_Id + is + begin + -- Generate: + -- Mark : constant Mark_Id := SS_Mark; + + return + Make_Object_Declaration (Loc, + Defining_Identifier => Mark, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Mark_Id), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_SS_Mark), Loc))); + end Build_SS_Mark_Call; + + --------------------------- + -- Build_SS_Release_Call -- + --------------------------- + + function Build_SS_Release_Call + (Loc : Source_Ptr; + Mark : Entity_Id) return Node_Id + is + begin + -- Generate: + -- SS_Release (Mark); + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_SS_Release), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Mark, Loc))); + end Build_SS_Release_Call; + ---------------------------- -- Build_Task_Array_Image -- ---------------------------- @@ -1590,6 +1633,68 @@ package body Exp_Util is return Build_Task_Image_Function (Loc, Decls, Stats, Res); end Build_Task_Record_Image; + ----------------------------- + -- Check_Float_Op_Overflow -- + ----------------------------- + + procedure Check_Float_Op_Overflow (N : Node_Id) is + begin + -- Return if no check needed + + if not Is_Floating_Point_Type (Etype (N)) + or else not (Do_Overflow_Check (N) and then Check_Float_Overflow) + + -- In CodePeer_Mode, rely on the overflow check flag being set instead + -- and do not expand the code for float overflow checking. + + or else CodePeer_Mode + then + return; + end if; + + -- Otherwise we replace the expression by + + -- do Tnn : constant ftype := expression; + -- constraint_error when not Tnn'Valid; + -- in Tnn; + + declare + Loc : constant Source_Ptr := Sloc (N); + Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); + Typ : constant Entity_Id := Etype (N); + + begin + -- Turn off the Do_Overflow_Check flag, since we are doing that work + -- right here. We also set the node as analyzed to prevent infinite + -- recursion from repeating the operation in the expansion. + + Set_Do_Overflow_Check (N, False); + Set_Analyzed (N, True); + + -- Do the rewrite to include the check + + Rewrite (N, + Make_Expression_With_Actions (Loc, + Actions => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Tnn, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Constant_Present => True, + Expression => Relocate_Node (N)), + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Tnn, Loc), + Attribute_Name => Name_Valid)), + Reason => CE_Overflow_Check_Failed)), + Expression => New_Occurrence_Of (Tnn, Loc))); + + Analyze_And_Resolve (N, Typ); + end; + end Check_Float_Op_Overflow; + ---------------------------------- -- Component_May_Be_Bit_Aligned -- ---------------------------------- @@ -1748,11 +1853,12 @@ package body Exp_Util is ----------------------- function Duplicate_Subexpr - (Exp : Node_Id; - Name_Req : Boolean := False) return Node_Id + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is begin - Remove_Side_Effects (Exp, Name_Req); + Remove_Side_Effects (Exp, Name_Req, Renaming_Req); return New_Copy_Tree (Exp); end Duplicate_Subexpr; @@ -1761,12 +1867,14 @@ package body Exp_Util is --------------------------------- function Duplicate_Subexpr_No_Checks - (Exp : Node_Id; - Name_Req : Boolean := False) return Node_Id + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; + begin - Remove_Side_Effects (Exp, Name_Req); + Remove_Side_Effects (Exp, Name_Req, Renaming_Req); New_Exp := New_Copy_Tree (Exp); Remove_Checks (New_Exp); return New_Exp; @@ -1777,12 +1885,14 @@ package body Exp_Util is ----------------------------------- function Duplicate_Subexpr_Move_Checks - (Exp : Node_Id; - Name_Req : Boolean := False) return Node_Id + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; + begin - Remove_Side_Effects (Exp, Name_Req); + Remove_Side_Effects (Exp, Name_Req, Renaming_Req); New_Exp := New_Copy_Tree (Exp); Remove_Checks (Exp); return New_Exp; @@ -1980,7 +2090,7 @@ package body Exp_Util is -- if the list is empty, corresponding to a False predicate, then -- no choices are inserted. - P := First (Static_Predicate (Entity (Choice))); + P := First (Static_Discrete_Predicate (Entity (Choice))); while Present (P) loop -- If low bound and high bounds are equal, copy simple choice @@ -3185,6 +3295,62 @@ package body Exp_Util is end; end Get_Current_Value_Condition; + ------------------------------------------------- + -- Get_First_Parent_With_Ext_Axioms_For_Entity -- + ------------------------------------------------- + + function Get_First_Parent_With_Ext_Axioms_For_Entity + (E : Entity_Id) return Entity_Id + is + Decl : Node_Id; + + begin + 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; + end if; + + -- E is the package or generic package which is externally axiomatized + + if Ekind_In (E, E_Package, E_Generic_Package) + and then Has_Annotate_Pragma_For_External_Axiomatization (E) + then + return E; + end if; + + -- If E's scope is axiomatized, E is axiomatized. + + declare + First_Ax_Parent_Scope : Entity_Id := Empty; + + begin + if Present (Scope (E)) then + First_Ax_Parent_Scope := + Get_First_Parent_With_Ext_Axioms_For_Entity (Scope (E)); + end if; + + if Present (First_Ax_Parent_Scope) then + return First_Ax_Parent_Scope; + end if; + + -- otherwise, if E is a package instance, it is axiomatized if the + -- corresponding generic package is axiomatized. + + if Ekind (E) = E_Package + and then Present (Generic_Parent (Decl)) + then + return + Get_First_Parent_With_Ext_Axioms_For_Entity + (Generic_Parent (Decl)); + else + return Empty; + end if; + end; + end Get_First_Parent_With_Ext_Axioms_For_Entity; + --------------------- -- Get_Stream_Size -- --------------------- @@ -3228,6 +3394,122 @@ package body Exp_Util is end if; end Has_Access_Constraint; + ----------------------------------------------------- + -- Has_Annotate_Pragma_For_External_Axiomatization -- + ----------------------------------------------------- + + function Has_Annotate_Pragma_For_External_Axiomatization + (E : Entity_Id) return Boolean + is + function Is_Annotate_Pragma_For_External_Axiomatization + (N : Node_Id) return Boolean; + -- Returns whether N is + -- pragma Annotate (GNATprove, External_Axiomatization); + + ---------------------------------------------------- + -- Is_Annotate_Pragma_For_External_Axiomatization -- + ---------------------------------------------------- + + -- The general form of pragma Annotate is + + -- pragma Annotate (IDENTIFIER [, IDENTIFIER {, ARG}]); + -- ARG ::= NAME | EXPRESSION + + -- The first two arguments are by convention intended to refer to an + -- external tool and a tool-specific function. These arguments are + -- not analyzed. + + -- The following is used to annotate a package specification which + -- GNATprove should treat specially, because the axiomatization of + -- this unit is given by the user instead of being automatically + -- generated. + + -- pragma Annotate (GNATprove, External_Axiomatization); + + function Is_Annotate_Pragma_For_External_Axiomatization + (N : Node_Id) return Boolean + is + Name_GNATprove : constant String := + "gnatprove"; + Name_External_Axiomatization : constant String := + "external_axiomatization"; + -- Special names + + begin + if Nkind (N) = N_Pragma + and then Get_Pragma_Id (Pragma_Name (N)) = Pragma_Annotate + and then List_Length (Pragma_Argument_Associations (N)) = 2 + then + declare + Arg1 : constant Node_Id := + First (Pragma_Argument_Associations (N)); + Arg2 : constant Node_Id := Next (Arg1); + Nam1 : Name_Id; + Nam2 : Name_Id; + + begin + -- Fill in Name_Buffer with Name_GNATprove first, and then with + -- Name_External_Axiomatization so that Name_Find returns the + -- corresponding name. This takes care of all possible casings. + + Name_Len := 0; + Add_Str_To_Name_Buffer (Name_GNATprove); + Nam1 := Name_Find; + + Name_Len := 0; + Add_Str_To_Name_Buffer (Name_External_Axiomatization); + Nam2 := Name_Find; + + return Chars (Get_Pragma_Arg (Arg1)) = Nam1 + and then + Chars (Get_Pragma_Arg (Arg2)) = Nam2; + end; + + else + return False; + end if; + end Is_Annotate_Pragma_For_External_Axiomatization; + + -- Local variables + + Decl : Node_Id; + Vis_Decls : List_Id; + N : Node_Id; + + -- Start of processing for Has_Annotate_Pragma_For_External_Axiomatization + + begin + if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then + Decl := Parent (Parent (E)); + else + Decl := Parent (E); + end if; + + Vis_Decls := Visible_Declarations (Decl); + + N := First (Vis_Decls); + while Present (N) loop + + -- Skip declarations generated by the frontend. Skip all pragmas + -- that are not the desired Annotate pragma. Stop the search on + -- the first non-pragma source declaration. + + if Comes_From_Source (N) then + if Nkind (N) = N_Pragma then + if Is_Annotate_Pragma_For_External_Axiomatization (N) then + return True; + end if; + else + return False; + end if; + end if; + + Next (N); + end loop; + + return False; + end Has_Annotate_Pragma_For_External_Axiomatization; + ---------------------------------- -- Has_Following_Address_Clause -- ---------------------------------- @@ -3435,9 +3717,8 @@ package body Exp_Util is or else Etype (Assoc_Node) /= Standard_Void_Type) and then Nkind (Assoc_Node) /= N_Procedure_Call_Statement and then (Nkind (Assoc_Node) /= N_Attribute_Reference - or else - not Is_Procedure_Attribute_Name - (Attribute_Name (Assoc_Node))) + or else not Is_Procedure_Attribute_Name + (Attribute_Name (Assoc_Node))) then N := Assoc_Node; P := Parent (Assoc_Node); @@ -4652,8 +4933,7 @@ package body Exp_Util is if Nkind (Stmt) = N_Object_Declaration and then Present (Expression (Stmt)) and then Nkind (Expression (Stmt)) = N_Reference - and then Nkind (Prefix (Expression (Stmt))) = - N_Function_Call + and then Nkind (Prefix (Expression (Stmt))) = N_Function_Call then Call := Prefix (Expression (Stmt)); @@ -4875,6 +5155,12 @@ package body Exp_Util is T : constant Entity_Id := Etype (N); begin + -- Objects are never unaligned on VMs + + if VM_Target /= No_VM then + return False; + end if; + -- If renamed object, apply test to underlying object if Is_Entity_Name (N) @@ -5043,18 +5329,6 @@ package body Exp_Util is return False; end if; - -- Always assume the worst for a nested record component with a - -- component clause, which gigi/gcc does not appear to handle well. - -- It is not clear why this special test is needed at all ??? - - if Nkind (Prefix (N)) = N_Selected_Component - and then Nkind (Prefix (Prefix (N))) = N_Selected_Component - and then - Present (Component_Clause (Entity (Selector_Name (Prefix (N))))) - then - return True; - end if; - -- We only need to worry if the target has strict alignment if not Target_Strict_Alignment then @@ -5438,6 +5712,8 @@ package body Exp_Util is -- that it is common and reasonable for code to be deleted in -- instances for various reasons. + -- Could we use Is_Statically_Unevaluated here??? + if Nkind (Parent (N)) = N_If_Statement then declare C : constant Node_Id := Condition (Parent (N)); @@ -5486,6 +5762,7 @@ package body Exp_Util is declare E : Entity_Id := First_Entity (Defining_Entity (N)); + begin while Present (E) loop if Ekind (E) = E_Operator then @@ -5501,7 +5778,7 @@ package body Exp_Util is elsif Nkind (N) = N_If_Statement then Kill_Dead_Code (Then_Statements (N)); - Kill_Dead_Code (Elsif_Parts (N)); + Kill_Dead_Code (Elsif_Parts (N)); Kill_Dead_Code (Else_Statements (N)); elsif Nkind (N) = N_Loop_Statement then @@ -5534,8 +5811,10 @@ package body Exp_Util is procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is N : Node_Id; W : Boolean; + begin W := Warn; + if Is_Non_Empty_List (L) then N := First (L); while Present (N) loop @@ -5826,10 +6105,14 @@ package body Exp_Util is Set_Is_Class_Wide_Equivalent_Type (Equiv_Type); + -- A class-wide equivalent type does not require initialization + + Set_Suppress_Initialization (Equiv_Type); + if not Is_Interface (Root_Typ) then Append_To (Comp_List, Make_Component_Declaration (Loc, - Defining_Identifier => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uParent), Component_Definition => Make_Component_Definition (Loc, @@ -5848,9 +6131,9 @@ package body Exp_Util is Append_To (List_Def, Make_Full_Type_Declaration (Loc, Defining_Identifier => Equiv_Type, - Type_Definition => + Type_Definition => Make_Record_Definition (Loc, - Component_List => + Component_List => Make_Component_List (Loc, Component_Items => Comp_List, Variant_Part => Empty)))); @@ -6059,7 +6342,7 @@ package body Exp_Util is -- 2. If Expr is a unconstrained discriminated type expression, creates -- Unc_Type(Expr.Discr1, ... , Expr.Discr_n) - -- 3. If Expr is class-wide, creates an implicit class wide subtype + -- 3. If Expr is class-wide, creates an implicit class-wide subtype function Make_Subtype_From_Expr (E : Node_Id; @@ -6148,8 +6431,8 @@ package body Exp_Util is if Expander_Active and then Tagged_Type_Expansion then - -- If this is the class_wide type of a completion that is a - -- record subtype, set the type of the class_wide type to be + -- If this is the class-wide type of a completion that is a + -- record subtype, set the type of the class-wide type to be -- the full base type, for use in the expanded code for the -- equivalent type. Should this be done earlier when the -- completion is analyzed ??? @@ -6761,7 +7044,7 @@ package body Exp_Util is Analyze (Block); end if; - when others => + when others => null; end case; end Process_Statements_For_Controlled_Objects; @@ -6773,6 +7056,7 @@ package body Exp_Util is function Power_Of_Two (N : Node_Id) return Nat is Typ : constant Entity_Id := Etype (N); pragma Assert (Is_Integer_Type (Typ)); + Siz : constant Nat := UI_To_Int (Esize (Typ)); Val : Uint; @@ -6899,6 +7183,7 @@ package body Exp_Util is procedure Remove_Side_Effects (Exp : Node_Id; Name_Req : Boolean := False; + Renaming_Req : Boolean := False; Variable_Ref : Boolean := False) is Loc : constant Source_Ptr := Sloc (Exp); @@ -6984,14 +7269,30 @@ package body Exp_Util is Set_Analyzed (Prefix (Exp), False); end if; - E := - Make_Object_Declaration (Loc, - Defining_Identifier => Def_Id, - Object_Definition => New_Occurrence_Of (Exp_Type, Loc), - Constant_Present => True, - Expression => Relocate_Node (Exp)); + -- Generate: + -- Rnn : Exp_Type renames Expr; + + if Renaming_Req then + E := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc), + Name => Relocate_Node (Exp)); + + -- Generate: + -- Rnn : constant Exp_Type := Expr; + + else + E := + Make_Object_Declaration (Loc, + Defining_Identifier => Def_Id, + Object_Definition => New_Occurrence_Of (Exp_Type, Loc), + Constant_Present => True, + Expression => Relocate_Node (Exp)); + + Set_Assignment_OK (E); + end if; - Set_Assignment_OK (E); Insert_Action (Exp, E); -- If the expression has the form v.all then we can just capture the @@ -7441,9 +7742,7 @@ package body Exp_Util is elsif Is_Access_Type (Obj_Typ) and then Present (Status_Flag_Or_Transient_Decl (Obj_Id)) and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) = - N_Object_Declaration - and then Is_Finalizable_Transient - (Status_Flag_Or_Transient_Decl (Obj_Id), Decl) + N_Object_Declaration then return True; @@ -7464,9 +7763,8 @@ package body Exp_Util is -- treated as controlled since they require manual cleanup. elsif Ekind (Obj_Id) = E_Variable - and then - (Is_Simple_Protected_Type (Obj_Typ) - or else Has_Simple_Protected_Object (Obj_Typ)) + and then (Is_Simple_Protected_Type (Obj_Typ) + or else Has_Simple_Protected_Object (Obj_Typ)) then return True; end if; @@ -7529,9 +7827,7 @@ package body Exp_Util is and then not Is_Access_Subprogram_Type (Typ) and then Needs_Finalization (Available_View (Designated_Type (Typ)))) - or else - (Is_Type (Typ) - and then Needs_Finalization (Typ))) + or else (Is_Type (Typ) and then Needs_Finalization (Typ))) and then Requires_Cleanup_Actions (Actions (Decl), Lib_Level, Nested_Constructs) then @@ -7756,7 +8052,8 @@ package body Exp_Util is if Ialign /= No_Uint and then Ialign > Maximum_Alignment then return True; - elsif Ialign /= No_Uint and then Oalign /= No_Uint + elsif Ialign /= No_Uint + and then Oalign /= No_Uint and then Ialign <= Oalign then return True; @@ -7920,6 +8217,50 @@ package body Exp_Util is -- pick up bogus indications of the wrong constant value. Set_Current_Value (Ent, Empty); + + -- If the subprogram is in the current declarative part and + -- 'access has been applied to it, generate an elaboration + -- check at the beginning of the declarations of the body. + + if Nkind (N) = N_Subprogram_Body + and then Address_Taken (Spec_Id) + and then + Ekind_In (Scope (Spec_Id), E_Block, E_Procedure, E_Function) + then + declare + Loc : constant Source_Ptr := Sloc (N); + Decls : constant List_Id := Declarations (N); + Chk : Node_Id; + + begin + -- No need to generate this check if first entry in the + -- declaration list is a raise of Program_Error now. + + if Present (Decls) + and then Nkind (First (Decls)) = N_Raise_Program_Error + then + return; + end if; + + -- Otherwise generate the check + + Chk := + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Ent, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Reason => PE_Access_Before_Elaboration); + + if No (Decls) then + Set_Declarations (N, New_List (Chk)); + else + Prepend (Chk, Decls); + end if; + + Analyze (Chk); + end; + end if; end if; end if; end Set_Elaboration_Flag; @@ -8327,7 +8668,7 @@ package body Exp_Util is when N_Range => return Side_Effect_Free (Low_Bound (N), Name_Req, Variable_Ref) - and then + and then Side_Effect_Free (High_Bound (N), Name_Req, Variable_Ref); -- A slice is side effect free if it is a side effect free @@ -8698,7 +9039,6 @@ package body Exp_Util is Loc : constant Source_Ptr := Sloc (N); Stseq : constant Node_Id := Handled_Statement_Sequence (N); Stmts : constant List_Id := Statements (Stseq); - begin if Abort_Allowed then Prepend_To (Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); diff --git a/main/gcc/ada/exp_util.ads b/main/gcc/ada/exp_util.ads index 2f316ddb8d1..cdc2a24adbd 100644 --- a/main/gcc/ada/exp_util.ads +++ b/main/gcc/ada/exp_util.ads @@ -244,6 +244,18 @@ package Exp_Util is -- information for the tree and for error messages. The call node is not -- analyzed on return, the caller is responsible for analyzing it. + function Build_SS_Mark_Call + (Loc : Source_Ptr; + Mark : Entity_Id) return Node_Id; + -- Build a call to routine System.Secondary_Stack.Mark. Mark denotes the + -- entity of the secondary stack mark. + + function Build_SS_Release_Call + (Loc : Source_Ptr; + Mark : Entity_Id) return Node_Id; + -- Build a call to routine System.Secondary_Stack.Release. Mark denotes the + -- entity of the secondary stack mark. + function Build_Task_Image_Decls (Loc : Source_Ptr; Id_Ref : Node_Id; @@ -264,6 +276,13 @@ 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 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 + -- mode. Note that we don't need to worry about unary operator cases, + -- since for floating-point, abs, unary "-", and unary "+" can never + -- case overflow. + function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean; -- This function is in charge of detecting record components that may -- cause trouble in the back end if an attempt is made to assign the @@ -318,8 +337,9 @@ package Exp_Util is -- be the earliest point at which they are used. function Duplicate_Subexpr - (Exp : Node_Id; - Name_Req : Boolean := False) return Node_Id; + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Given the node for a subexpression, this function makes a logical copy -- of the subexpression, and returns it. This is intended for use when the -- expansion of an expression needs to repeat part of it. For example, @@ -331,17 +351,25 @@ package Exp_Util is -- expression and the returned result then become references to this saved -- value. Exp must be analyzed on entry. On return, Exp is analyzed, but -- the caller is responsible for analyzing the returned copy after it is - -- attached to the tree. The Name_Req flag is set to ensure that the result - -- is suitable for use in a context requiring name (e.g. the prefix of an - -- attribute reference). + -- attached to the tree. + -- + -- The Name_Req flag is set to ensure that the result is suitable for use + -- in a context requiring a name (for example, the prefix of an attribute + -- reference) (can't this just be a qualification in Ada 2012???). + -- + -- The Renaming_Req flag is set to produce an object renaming declaration + -- rather than an object declaration. This is valid only if the expression + -- Exp designates a renamable object. This is used for example in the case + -- of an unchecked deallocation, to make sure the object gets set to null. -- -- Note that if there are any run time checks in Exp, these same checks -- will be duplicated in the returned duplicated expression. The two -- following functions allow this behavior to be modified. function Duplicate_Subexpr_No_Checks - (Exp : Node_Id; - Name_Req : Boolean := False) return Node_Id; + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks -- is called on the result, so that the duplicated expression does not -- include checks. This is appropriate for use when Exp, the original @@ -349,8 +377,9 @@ package Exp_Util is -- expression, so that there is no need to repeat any checks. function Duplicate_Subexpr_Move_Checks - (Exp : Node_Id; - Name_Req : Boolean := False) return Node_Id; + (Exp : Node_Id; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on Exp after the duplication is complete, so that the original -- expression does not include checks. In this case the result returned @@ -513,12 +542,23 @@ package Exp_Util is -- N_Op_Eq), or to determine the result of some other test in other cases -- (e.g. no access check required if N_Op_Ne Null). + function Get_First_Parent_With_Ext_Axioms_For_Entity + (E : Entity_Id) return Entity_Id; + -- Returns the package entity with an external axiomatization containing E, + -- if any, or Empty if none. + function Get_Stream_Size (E : Entity_Id) return Uint; -- Return the stream size value of the subtype E function Has_Access_Constraint (E : Entity_Id) return Boolean; -- Given object or type E, determine if a discriminant is of an access type + function Has_Annotate_Pragma_For_External_Axiomatization + (E : Entity_Id) return Boolean; + -- Returns whether E is a package entity, for which the initial list of + -- pragmas at the start of the package declaration contains + -- pragma Annotate (GNATprove, External_Axiomatization); + function Has_Following_Address_Clause (D : Node_Id) return Boolean; -- D is the node for an object declaration. This function searches the -- current declarative part to look for an address clause for the object @@ -785,6 +825,7 @@ package Exp_Util is procedure Remove_Side_Effects (Exp : Node_Id; Name_Req : Boolean := False; + Renaming_Req : Boolean := False; Variable_Ref : Boolean := False); -- Given the node for a subexpression, this function replaces the node if -- necessary by an equivalent subexpression that is guaranteed to be side @@ -793,10 +834,12 @@ package Exp_Util is -- to which Exp is attached. Exp must be analyzed and resolved before the -- call and is analyzed and resolved on return. Name_Req may only be set to -- True if Exp has the form of a name, and the effect is to guarantee that - -- any replacement maintains the form of name. 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. + -- any replacement maintains the form of name. If Renaming_Req is set to + -- TRUE, the routine produces an object renaming reclaration capturing the + -- 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. function Represented_As_Scalar (T : Entity_Id) return Boolean; -- Returns True iff the implementation of this type in code generation diff --git a/main/gcc/ada/exp_vfpt.adb b/main/gcc/ada/exp_vfpt.adb deleted file mode 100644 index 82d2fe16e7d..00000000000 --- a/main/gcc/ada/exp_vfpt.adb +++ /dev/null @@ -1,690 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ V F P T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Atree; use Atree; -with Einfo; use Einfo; -with Nlists; use Nlists; -with Nmake; use Nmake; -with Rtsfind; use Rtsfind; -with Sem_Res; use Sem_Res; -with Sinfo; use Sinfo; -with Stand; use Stand; -with Tbuild; use Tbuild; -with Urealp; use Urealp; -with Eval_Fat; use Eval_Fat; - -package body Exp_VFpt is - - -- Vax floating point format (from Vax Architecture Reference Manual - -- version 6): - - -- Float F: - -- -------- - - -- 1 1 - -- 5 4 7 6 0 - -- +-+---------------+--------------+ - -- |S| exp | fraction | A - -- +-+---------------+--------------+ - -- | fraction | A + 2 - -- +--------------------------------+ - - -- bit 15 is the sign bit, - -- bits 14:7 is the excess 128 binary exponent, - -- bits 6:0 and 31:16 the normalized 24-bit fraction with the redundant - -- most significant fraction bit not represented. - - -- An exponent value of 0 together with a sign bit of 0, is taken to - -- indicate that the datum has a value of 0. Exponent values of 1 through - -- 255 indicate true binary exponents of -127 to +127. An exponent value - -- of 0, together with a sign bit of 1, is taken as reserved. - - -- Note that fraction bits are not continuous in memory, VAX is little - -- endian (LSB first). - - -- Float D: - -- -------- - - -- 1 1 - -- 5 4 7 6 0 - -- +-+---------------+--------------+ - -- |S| exp | fraction | A - -- +-+---------------+--------------+ - -- | fraction | A + 2 - -- +--------------------------------+ - -- | fraction | A + 4 - -- +--------------------------------+ - -- | fraction (low) | A + 6 - -- +--------------------------------+ - - -- Note that the fraction bits are not continuous in memory. Bytes in a - -- words are stored in little endian format, but words are stored using - -- big endian format (PDP endian). - - -- Like Float F but with 55 bits for the fraction. - - -- Float G: - -- -------- - - -- 1 1 - -- 5 4 4 3 0 - -- +-+---------------------+--------+ - -- |S| exp | fract | A - -- +-+---------------------+--------+ - -- | fraction | A + 2 - -- +--------------------------------+ - -- | fraction | A + 4 - -- +--------------------------------+ - -- | fraction (low) | A + 6 - -- +--------------------------------+ - - -- Exponent values of 1 through 2047 indicate true binary exponents of - -- -1023 to +1023. - - -- Main differences compared to IEEE 754: - - -- * No denormalized numbers - -- * No infinity - -- * No NaN - -- * No -0.0 - -- * Reserved values (exp = 0, sign = 1) - -- * Vax mantissa represent values [0.5, 1) - -- * Bias is shifted by 1 (for single float: 128 on Vax, 127 on IEEE) - - VAXFF_Digits : constant := 6; - VAXDF_Digits : constant := 9; - VAXGF_Digits : constant := 15; - - ---------------------- - -- Expand_Vax_Arith -- - ---------------------- - - procedure Expand_Vax_Arith (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Base_Type (Etype (N)); - Typc : Character; - Atyp : Entity_Id; - Func : RE_Id; - Args : List_Id; - - begin - -- Get arithmetic type, note that we do D stuff in G - - if Digits_Value (Typ) = VAXFF_Digits then - Typc := 'F'; - Atyp := RTE (RE_F); - else - Typc := 'G'; - Atyp := RTE (RE_G); - end if; - - case Nkind (N) is - - when N_Op_Abs => - if Typc = 'F' then - Func := RE_Abs_F; - else - Func := RE_Abs_G; - end if; - - when N_Op_Add => - if Typc = 'F' then - Func := RE_Add_F; - else - Func := RE_Add_G; - end if; - - when N_Op_Divide => - if Typc = 'F' then - Func := RE_Div_F; - else - Func := RE_Div_G; - end if; - - when N_Op_Multiply => - if Typc = 'F' then - Func := RE_Mul_F; - else - Func := RE_Mul_G; - end if; - - when N_Op_Minus => - if Typc = 'F' then - Func := RE_Neg_F; - else - Func := RE_Neg_G; - end if; - - when N_Op_Subtract => - if Typc = 'F' then - Func := RE_Sub_F; - else - Func := RE_Sub_G; - end if; - - when others => - Func := RE_Null; - raise Program_Error; - - end case; - - Args := New_List; - - if Nkind (N) in N_Binary_Op then - Append_To (Args, - Convert_To (Atyp, Left_Opnd (N))); - end if; - - Append_To (Args, - Convert_To (Atyp, Right_Opnd (N))); - - Rewrite (N, - Convert_To (Typ, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (Func), Loc), - Parameter_Associations => Args))); - - Analyze_And_Resolve (N, Typ, Suppress => All_Checks); - end Expand_Vax_Arith; - - --------------------------- - -- Expand_Vax_Comparison -- - --------------------------- - - procedure Expand_Vax_Comparison (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Base_Type (Etype (Left_Opnd (N))); - Typc : Character; - Func : RE_Id; - Atyp : Entity_Id; - Revrs : Boolean := False; - Args : List_Id; - - begin - -- Get arithmetic type, note that we do D stuff in G - - if Digits_Value (Typ) = VAXFF_Digits then - Typc := 'F'; - Atyp := RTE (RE_F); - else - Typc := 'G'; - Atyp := RTE (RE_G); - end if; - - case Nkind (N) is - - when N_Op_Eq => - if Typc = 'F' then - Func := RE_Eq_F; - else - Func := RE_Eq_G; - end if; - - when N_Op_Ge => - if Typc = 'F' then - Func := RE_Le_F; - else - Func := RE_Le_G; - end if; - - Revrs := True; - - when N_Op_Gt => - if Typc = 'F' then - Func := RE_Lt_F; - else - Func := RE_Lt_G; - end if; - - Revrs := True; - - when N_Op_Le => - if Typc = 'F' then - Func := RE_Le_F; - else - Func := RE_Le_G; - end if; - - when N_Op_Lt => - if Typc = 'F' then - Func := RE_Lt_F; - else - Func := RE_Lt_G; - end if; - - when N_Op_Ne => - if Typc = 'F' then - Func := RE_Ne_F; - else - Func := RE_Ne_G; - end if; - - when others => - Func := RE_Null; - raise Program_Error; - - end case; - - if not Revrs then - Args := New_List ( - Convert_To (Atyp, Left_Opnd (N)), - Convert_To (Atyp, Right_Opnd (N))); - - else - Args := New_List ( - Convert_To (Atyp, Right_Opnd (N)), - Convert_To (Atyp, Left_Opnd (N))); - end if; - - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (Func), Loc), - Parameter_Associations => Args)); - - Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); - end Expand_Vax_Comparison; - - --------------------------- - -- Expand_Vax_Conversion -- - --------------------------- - - procedure Expand_Vax_Conversion (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Expr : constant Node_Id := Expression (N); - S_Typ : constant Entity_Id := Base_Type (Etype (Expr)); - T_Typ : constant Entity_Id := Base_Type (Etype (N)); - - CallS : RE_Id; - CallT : RE_Id; - Func : RE_Id; - - function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id; - -- Given one of the two types T, determines the corresponding call - -- type, i.e. the type to be used for the call (or the result of - -- the call). The actual operand is converted to (or from) this type. - -- Otyp is the other type, which is useful in figuring out the result. - -- The result returned is the RE_Id value for the type entity. - - function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id; - -- Find the predefined integer type that has the same size as the - -- fixed-point type T, for use in fixed/float conversions. - - --------------- - -- Call_Type -- - --------------- - - function Call_Type (T : Entity_Id; Otyp : Entity_Id) return RE_Id is - begin - -- Vax float formats - - if Vax_Float (T) then - if Digits_Value (T) = VAXFF_Digits then - return RE_F; - - elsif Digits_Value (T) = VAXGF_Digits then - return RE_G; - - -- For D_Float, leave it as D float if the other operand is - -- G_Float, since this is the one conversion that is properly - -- supported for D_Float, but otherwise, use G_Float. - - else pragma Assert (Digits_Value (T) = VAXDF_Digits); - - if Vax_Float (Otyp) - and then Digits_Value (Otyp) = VAXGF_Digits - then - return RE_D; - else - return RE_G; - end if; - end if; - - -- For all discrete types, use 64-bit integer - - elsif Is_Discrete_Type (T) then - return RE_Q; - - -- For all real types (other than Vax float format), we use the - -- IEEE float-type which corresponds in length to the other type - -- (which is Vax Float). - - else pragma Assert (Is_Real_Type (T)); - - if Digits_Value (Otyp) = VAXFF_Digits then - return RE_S; - else - return RE_T; - end if; - end if; - end Call_Type; - - ------------------------------------------------- - -- Expand_Multiply_Fixed_By_Fixed_Giving_Fixed -- - ------------------------------------------------- - - function Equivalent_Integer_Type (T : Entity_Id) return Entity_Id is - begin - if Esize (T) = Esize (Standard_Long_Long_Integer) then - return Standard_Long_Long_Integer; - elsif Esize (T) = Esize (Standard_Long_Integer) then - return Standard_Long_Integer; - else - return Standard_Integer; - end if; - end Equivalent_Integer_Type; - - -- Start of processing for Expand_Vax_Conversion; - - begin - -- If input and output are the same Vax type, we change the - -- conversion to be an unchecked conversion and that's it. - - if Vax_Float (S_Typ) and then Vax_Float (T_Typ) - and then Digits_Value (S_Typ) = Digits_Value (T_Typ) - then - Rewrite (N, - Unchecked_Convert_To (T_Typ, Expr)); - - -- Case of conversion of fixed-point type to Vax_Float type - - elsif Is_Fixed_Point_Type (S_Typ) then - - -- If Conversion_OK set, then we introduce an intermediate IEEE - -- target type since we are expecting the code generator to handle - -- the case of integer to IEEE float. - - if Conversion_OK (N) then - Rewrite (N, - Convert_To (T_Typ, OK_Convert_To (Universal_Real, Expr))); - - -- Otherwise, convert the scaled integer value to the target type, - -- and multiply by 'Small of type. - - else - Rewrite (N, - Make_Op_Multiply (Loc, - Left_Opnd => - Make_Type_Conversion (Loc, - Subtype_Mark => New_Occurrence_Of (T_Typ, Loc), - Expression => - Unchecked_Convert_To ( - Equivalent_Integer_Type (S_Typ), Expr)), - Right_Opnd => - Make_Real_Literal (Loc, Realval => Small_Value (S_Typ)))); - end if; - - -- Case of conversion of Vax_Float type to fixed-point type - - elsif Is_Fixed_Point_Type (T_Typ) then - - -- If Conversion_OK set, then we introduce an intermediate IEEE - -- target type, since we are expecting the code generator to handle - -- the case of IEEE float to integer. - - if Conversion_OK (N) then - Rewrite (N, - OK_Convert_To (T_Typ, Convert_To (Universal_Real, Expr))); - - -- Otherwise, multiply value by 'small of type, and convert to the - -- corresponding integer type. - - else - Rewrite (N, - Unchecked_Convert_To (T_Typ, - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of (Equivalent_Integer_Type (T_Typ), Loc), - Expression => - Make_Op_Multiply (Loc, - Left_Opnd => Expr, - Right_Opnd => - Make_Real_Literal (Loc, - Realval => Ureal_1 / Small_Value (T_Typ)))))); - end if; - - -- All other cases - - else - -- Compute types for call - - CallS := Call_Type (S_Typ, T_Typ); - CallT := Call_Type (T_Typ, S_Typ); - - -- Get function and its types - - if CallS = RE_D and then CallT = RE_G then - Func := RE_D_To_G; - - elsif CallS = RE_G and then CallT = RE_D then - Func := RE_G_To_D; - - elsif CallS = RE_G and then CallT = RE_F then - Func := RE_G_To_F; - - elsif CallS = RE_F and then CallT = RE_G then - Func := RE_F_To_G; - - elsif CallS = RE_F and then CallT = RE_S then - Func := RE_F_To_S; - - elsif CallS = RE_S and then CallT = RE_F then - Func := RE_S_To_F; - - elsif CallS = RE_G and then CallT = RE_T then - Func := RE_G_To_T; - - elsif CallS = RE_T and then CallT = RE_G then - Func := RE_T_To_G; - - elsif CallS = RE_F and then CallT = RE_Q then - Func := RE_F_To_Q; - - elsif CallS = RE_Q and then CallT = RE_F then - Func := RE_Q_To_F; - - elsif CallS = RE_G and then CallT = RE_Q then - Func := RE_G_To_Q; - - else pragma Assert (CallS = RE_Q and then CallT = RE_G); - Func := RE_Q_To_G; - end if; - - Rewrite (N, - Convert_To (T_Typ, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (Func), Loc), - Parameter_Associations => New_List ( - Convert_To (RTE (CallS), Expr))))); - end if; - - Analyze_And_Resolve (N, T_Typ, Suppress => All_Checks); - end Expand_Vax_Conversion; - - ------------------------------- - -- Expand_Vax_Foreign_Return -- - ------------------------------- - - procedure Expand_Vax_Foreign_Return (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Typ : constant Entity_Id := Base_Type (Etype (N)); - Func : RE_Id; - Args : List_Id; - Atyp : Entity_Id; - Rtyp : constant Entity_Id := Etype (N); - - begin - if Digits_Value (Typ) = VAXFF_Digits then - Func := RE_Return_F; - Atyp := RTE (RE_F); - elsif Digits_Value (Typ) = VAXDF_Digits then - Func := RE_Return_D; - Atyp := RTE (RE_D); - else pragma Assert (Digits_Value (Typ) = VAXGF_Digits); - Func := RE_Return_G; - Atyp := RTE (RE_G); - end if; - - Args := New_List (Convert_To (Atyp, N)); - - Rewrite (N, - Convert_To (Rtyp, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (Func), Loc), - Parameter_Associations => Args))); - - Analyze_And_Resolve (N, Typ, Suppress => All_Checks); - end Expand_Vax_Foreign_Return; - - -------------------------------- - -- Vax_Real_Literal_As_Signed -- - -------------------------------- - - function Get_Vax_Real_Literal_As_Signed (N : Node_Id) return Uint is - Btyp : constant Entity_Id := - Base_Type (Underlying_Type (Etype (N))); - - Value : constant Ureal := Realval (N); - Negative : Boolean; - Fraction : UI; - Exponent : UI; - Res : UI; - - Exponent_Size : Uint; - -- Number of bits for the exponent - - Fraction_Size : Uint; - -- Number of bits for the fraction - - Uintp_Mark : constant Uintp.Save_Mark := Mark; - -- Use the mark & release feature to delete temporaries - begin - -- Extract the sign now - - Negative := UR_Is_Negative (Value); - - -- Decompose the number - - Decompose_Int (Btyp, abs Value, Fraction, Exponent, Round_Even); - - -- Number of bits for the fraction, leading fraction bit is implicit - - Fraction_Size := Machine_Mantissa_Value (Btyp) - Int'(1); - - -- Number of bits for the exponent (one bit for the sign) - - Exponent_Size := RM_Size (Btyp) - Fraction_Size - Int'(1); - - if Fraction = Uint_0 then - -- Handle zero - - Res := Uint_0; - - elsif Exponent <= -(Uint_2 ** (Exponent_Size - 1)) then - -- Underflow - - Res := Uint_0; - else - -- Check for overflow - - pragma Assert (Exponent < Uint_2 ** (Exponent_Size - 1)); - - -- MSB of the fraction must be 1 - - pragma Assert (Fraction / Uint_2 ** Fraction_Size = Uint_1); - - -- Remove the redudant most significant fraction bit - - Fraction := Fraction - Uint_2 ** Fraction_Size; - - -- Build the fraction part. Note that this field is in mixed - -- endianness: words are stored using little endianness, while bytes - -- in words are stored using big endianness. - - Res := Uint_0; - for I in 1 .. UI_To_Int (RM_Size (Btyp)) / 16 loop - Res := (Res * (Uint_2 ** 16)) + (Fraction mod (Uint_2 ** 16)); - Fraction := Fraction / (Uint_2 ** 16); - end loop; - - -- The sign bit - - if Negative then - Res := Res + Int (2**15); - end if; - - -- The exponent - - Res := Res + (Exponent + Uint_2 ** (Exponent_Size - 1)) - * Uint_2 ** (15 - Exponent_Size); - - -- Until now, we have created an unsigned number, but an underlying - -- type is a signed type. Convert to a signed number to avoid - -- overflow in gigi. - - if Res >= Uint_2 ** (Exponent_Size + Fraction_Size) then - Res := Res - Uint_2 ** (Exponent_Size + Fraction_Size + 1); - end if; - end if; - - Release_And_Save (Uintp_Mark, Res); - - return Res; - end Get_Vax_Real_Literal_As_Signed; - - ---------------------- - -- Expand_Vax_Valid -- - ---------------------- - - procedure Expand_Vax_Valid (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Pref : constant Node_Id := Prefix (N); - Ptyp : constant Entity_Id := Root_Type (Etype (Pref)); - Rtyp : constant Entity_Id := Etype (N); - Vtyp : RE_Id; - Func : RE_Id; - - begin - if Digits_Value (Ptyp) = VAXFF_Digits then - Func := RE_Valid_F; - Vtyp := RE_F; - elsif Digits_Value (Ptyp) = VAXDF_Digits then - Func := RE_Valid_D; - Vtyp := RE_D; - else pragma Assert (Digits_Value (Ptyp) = VAXGF_Digits); - Func := RE_Valid_G; - Vtyp := RE_G; - end if; - - Rewrite (N, - Convert_To (Rtyp, - Make_Function_Call (Loc, - Name => New_Occurrence_Of (RTE (Func), Loc), - Parameter_Associations => New_List ( - Convert_To (RTE (Vtyp), Pref))))); - - Analyze_And_Resolve (N); - end Expand_Vax_Valid; - -end Exp_VFpt; diff --git a/main/gcc/ada/exp_vfpt.ads b/main/gcc/ada/exp_vfpt.ads deleted file mode 100644 index db018669435..00000000000 --- a/main/gcc/ada/exp_vfpt.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- E X P _ V F P T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specialized routines for handling the expansion --- of arithmetic and conversion operations involving Vax format floating- --- point formats as used on the Vax and the Alpha and the ia64. - -with Types; use Types; -with Uintp; use Uintp; - -package Exp_VFpt is - - procedure Expand_Vax_Arith (N : Node_Id); - -- The node N is an arithmetic node (N_Op_Abs, N_Op_Add, N_Op_Sub, - -- N_Op_Div, N_Op_Mul, N_Op_Minus where the operands are in Vax float - -- format. This procedure expands the necessary call. - - procedure Expand_Vax_Comparison (N : Node_Id); - -- The node N is an arithmetic comparison node where the types to be - -- compared are in Vax float format. This procedure expands the necessary - -- call. - - procedure Expand_Vax_Conversion (N : Node_Id); - -- The node N is a type conversion node where either the source or the - -- target type, or both, are Vax floating-point type. - - procedure Expand_Vax_Foreign_Return (N : Node_Id); - -- The node N is a call to a foreign function that returns a Vax float - -- value in a floating point register. Wraps the call in an asm stub - -- that moves the return value to an integer location on Alpha/VMS, - -- noop everywhere else. - - function Get_Vax_Real_Literal_As_Signed (N : Node_Id) return Uint; - -- Get the Vax binary representation of a real literal whose type is a Vax - -- floating-point type. This is used by gigi. Previously we expanded real - -- literal to a call to a LIB$OTS routine that performed the conversion. - -- This worked correctly from a funcional point of view, but was - -- inefficient and generated huge functions for aggregate initializations. - - procedure Expand_Vax_Valid (N : Node_Id); - -- The node N is an attribute reference node for the Valid attribute where - -- the prefix is of a Vax floating-point type. This procedure expands the - -- necessary call for the validity test. - -end Exp_VFpt; diff --git a/main/gcc/ada/expander.adb b/main/gcc/ada/expander.adb index 4d15e09d3e3..ff1975955dc 100644 --- a/main/gcc/ada/expander.adb +++ b/main/gcc/ada/expander.adb @@ -83,6 +83,25 @@ package body Expander is and then (Full_Analysis or else not Expander_Active) and then not (Inside_A_Generic and then Expander_Active)); + -- 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 + -- mechanism for generic instances. + + if GNATprove_Mode then + if not Inside_A_Generic then + Expand_SPARK (N); + end if; + + Set_Analyzed (N, Full_Analysis); + + -- Regular expansion is normally followed by special handling for + -- transient scopes for unconstrained results, etc. but this is not + -- needed, and in general cannot be done correctly, in this mode, so + -- we are all done. + + return; + -- There are three reasons for the Expander_Active flag to be false -- The first is when are not generating code. In this mode the @@ -91,11 +110,6 @@ package body Expander is -- which case Full_Analysis = False. See the spec of Sem for more info -- on this. - -- Additionally, 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 mechanism for generic instances - -- The second reason for the Expander_Active flag to be False is that -- we are performing a pre-analysis. During pre-analysis all expansion -- activity is turned off to make sure nodes are semantically decorated @@ -112,9 +126,7 @@ package body Expander is -- given that the expansion actions that would normally process it will -- not take place. This prevents cascaded errors due to stack mismatch. - if not Expander_Active - and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode) - then + elsif not Expander_Active then Set_Analyzed (N, Full_Analysis); if Serious_Errors_Detected > 0 and then Scope_Is_Transient then @@ -126,352 +138,333 @@ package body Expander is return; else - Debug_A_Entry ("expanding ", N); - begin - -- In GNATprove mode we only need a very limited subset of - -- the usual expansions. This limited subset is implemented - -- in Expand_SPARK. - - if GNATprove_Mode then - Expand_SPARK (N); - Set_Analyzed (N); - - -- Regular expansion is normally followed by special handling - -- for transient scopes for unconstrained results, etc. but - -- this is not needed, and in general cannot be done correctly, - -- in this mode, so we are all done. - - return; - - -- Here for normal non-SPARK mode + Debug_A_Entry ("expanding ", N); - else - -- Processing depends on node kind. For full details on the - -- expansion activity required in each case, see bodies of - -- corresponding expand routines. + -- Processing depends on node kind. For full details on the + -- expansion activity required in each case, see bodies of + -- corresponding expand routines. - case Nkind (N) is + case Nkind (N) is - when N_Abort_Statement => - Expand_N_Abort_Statement (N); + when N_Abort_Statement => + Expand_N_Abort_Statement (N); - when N_Accept_Statement => - Expand_N_Accept_Statement (N); + when N_Accept_Statement => + Expand_N_Accept_Statement (N); - when N_Aggregate => - Expand_N_Aggregate (N); + when N_Aggregate => + Expand_N_Aggregate (N); - when N_Allocator => - Expand_N_Allocator (N); + when N_Allocator => + Expand_N_Allocator (N); - when N_And_Then => - Expand_N_And_Then (N); + when N_And_Then => + Expand_N_And_Then (N); - when N_Assignment_Statement => - Expand_N_Assignment_Statement (N); + when N_Assignment_Statement => + Expand_N_Assignment_Statement (N); - when N_Asynchronous_Select => - Expand_N_Asynchronous_Select (N); + when N_Asynchronous_Select => + Expand_N_Asynchronous_Select (N); - when N_Attribute_Definition_Clause => - Expand_N_Attribute_Definition_Clause (N); + when N_Attribute_Definition_Clause => + Expand_N_Attribute_Definition_Clause (N); - when N_Attribute_Reference => - Expand_N_Attribute_Reference (N); + when N_Attribute_Reference => + Expand_N_Attribute_Reference (N); - when N_Block_Statement => - Expand_N_Block_Statement (N); + when N_Block_Statement => + Expand_N_Block_Statement (N); - when N_Case_Expression => - Expand_N_Case_Expression (N); + when N_Case_Expression => + Expand_N_Case_Expression (N); - when N_Case_Statement => - Expand_N_Case_Statement (N); + when N_Case_Statement => + Expand_N_Case_Statement (N); - when N_Conditional_Entry_Call => - Expand_N_Conditional_Entry_Call (N); + when N_Conditional_Entry_Call => + Expand_N_Conditional_Entry_Call (N); - when N_Delay_Relative_Statement => - Expand_N_Delay_Relative_Statement (N); + when N_Delay_Relative_Statement => + Expand_N_Delay_Relative_Statement (N); - when N_Delay_Until_Statement => - Expand_N_Delay_Until_Statement (N); + when N_Delay_Until_Statement => + Expand_N_Delay_Until_Statement (N); - when N_Entry_Body => - Expand_N_Entry_Body (N); + when N_Entry_Body => + Expand_N_Entry_Body (N); - when N_Entry_Call_Statement => - Expand_N_Entry_Call_Statement (N); + when N_Entry_Call_Statement => + Expand_N_Entry_Call_Statement (N); - when N_Entry_Declaration => - Expand_N_Entry_Declaration (N); + when N_Entry_Declaration => + Expand_N_Entry_Declaration (N); - when N_Exception_Declaration => - Expand_N_Exception_Declaration (N); + when N_Exception_Declaration => + Expand_N_Exception_Declaration (N); - when N_Exception_Renaming_Declaration => - Expand_N_Exception_Renaming_Declaration (N); + when N_Exception_Renaming_Declaration => + Expand_N_Exception_Renaming_Declaration (N); - when N_Exit_Statement => - Expand_N_Exit_Statement (N); + when N_Exit_Statement => + Expand_N_Exit_Statement (N); - when N_Expanded_Name => - Expand_N_Expanded_Name (N); + when N_Expanded_Name => + Expand_N_Expanded_Name (N); - when N_Explicit_Dereference => - Expand_N_Explicit_Dereference (N); + when N_Explicit_Dereference => + Expand_N_Explicit_Dereference (N); - when N_Expression_With_Actions => - Expand_N_Expression_With_Actions (N); + when N_Expression_With_Actions => + Expand_N_Expression_With_Actions (N); - when N_Extended_Return_Statement => - Expand_N_Extended_Return_Statement (N); + when N_Extended_Return_Statement => + Expand_N_Extended_Return_Statement (N); - when N_Extension_Aggregate => - Expand_N_Extension_Aggregate (N); + when N_Extension_Aggregate => + Expand_N_Extension_Aggregate (N); - when N_Free_Statement => - Expand_N_Free_Statement (N); + when N_Free_Statement => + Expand_N_Free_Statement (N); - when N_Freeze_Entity => - Expand_N_Freeze_Entity (N); + when N_Freeze_Entity => + Expand_N_Freeze_Entity (N); - when N_Full_Type_Declaration => - Expand_N_Full_Type_Declaration (N); + when N_Full_Type_Declaration => + Expand_N_Full_Type_Declaration (N); - when N_Function_Call => - Expand_N_Function_Call (N); + when N_Function_Call => + Expand_N_Function_Call (N); - when N_Generic_Instantiation => - Expand_N_Generic_Instantiation (N); + when N_Generic_Instantiation => + Expand_N_Generic_Instantiation (N); - when N_Goto_Statement => - Expand_N_Goto_Statement (N); + when N_Goto_Statement => + Expand_N_Goto_Statement (N); - when N_Handled_Sequence_Of_Statements => - Expand_N_Handled_Sequence_Of_Statements (N); + when N_Handled_Sequence_Of_Statements => + Expand_N_Handled_Sequence_Of_Statements (N); - when N_Identifier => - Expand_N_Identifier (N); + when N_Identifier => + Expand_N_Identifier (N); - when N_If_Expression => - Expand_N_If_Expression (N); + when N_If_Expression => + Expand_N_If_Expression (N); - when N_Indexed_Component => - Expand_N_Indexed_Component (N); + when N_Indexed_Component => + Expand_N_Indexed_Component (N); - when N_If_Statement => - Expand_N_If_Statement (N); + when N_If_Statement => + Expand_N_If_Statement (N); - when N_In => - Expand_N_In (N); + when N_In => + Expand_N_In (N); - when N_Loop_Statement => - Expand_N_Loop_Statement (N); + when N_Loop_Statement => + Expand_N_Loop_Statement (N); - when N_Not_In => - Expand_N_Not_In (N); + when N_Not_In => + Expand_N_Not_In (N); - when N_Null => - Expand_N_Null (N); + when N_Null => + Expand_N_Null (N); - when N_Object_Declaration => - Expand_N_Object_Declaration (N); + when N_Object_Declaration => + Expand_N_Object_Declaration (N); - when N_Object_Renaming_Declaration => - Expand_N_Object_Renaming_Declaration (N); + when N_Object_Renaming_Declaration => + Expand_N_Object_Renaming_Declaration (N); - when N_Op_Add => - Expand_N_Op_Add (N); + when N_Op_Add => + Expand_N_Op_Add (N); - when N_Op_Abs => - Expand_N_Op_Abs (N); + when N_Op_Abs => + Expand_N_Op_Abs (N); - when N_Op_And => - Expand_N_Op_And (N); + when N_Op_And => + Expand_N_Op_And (N); - when N_Op_Concat => - Expand_N_Op_Concat (N); + when N_Op_Concat => + Expand_N_Op_Concat (N); - when N_Op_Divide => - Expand_N_Op_Divide (N); + when N_Op_Divide => + Expand_N_Op_Divide (N); - when N_Op_Eq => - Expand_N_Op_Eq (N); + when N_Op_Eq => + Expand_N_Op_Eq (N); - when N_Op_Expon => - Expand_N_Op_Expon (N); + when N_Op_Expon => + Expand_N_Op_Expon (N); - when N_Op_Ge => - Expand_N_Op_Ge (N); + when N_Op_Ge => + Expand_N_Op_Ge (N); - when N_Op_Gt => - Expand_N_Op_Gt (N); + when N_Op_Gt => + Expand_N_Op_Gt (N); - when N_Op_Le => - Expand_N_Op_Le (N); + when N_Op_Le => + Expand_N_Op_Le (N); - when N_Op_Lt => - Expand_N_Op_Lt (N); + when N_Op_Lt => + Expand_N_Op_Lt (N); - when N_Op_Minus => - Expand_N_Op_Minus (N); + when N_Op_Minus => + Expand_N_Op_Minus (N); - when N_Op_Mod => - Expand_N_Op_Mod (N); + when N_Op_Mod => + Expand_N_Op_Mod (N); - when N_Op_Multiply => - Expand_N_Op_Multiply (N); + when N_Op_Multiply => + Expand_N_Op_Multiply (N); - when N_Op_Ne => - Expand_N_Op_Ne (N); + when N_Op_Ne => + Expand_N_Op_Ne (N); - when N_Op_Not => - Expand_N_Op_Not (N); + when N_Op_Not => + Expand_N_Op_Not (N); - when N_Op_Or => - Expand_N_Op_Or (N); + when N_Op_Or => + Expand_N_Op_Or (N); - when N_Op_Plus => - Expand_N_Op_Plus (N); + when N_Op_Plus => + Expand_N_Op_Plus (N); - when N_Op_Rem => - Expand_N_Op_Rem (N); + when N_Op_Rem => + Expand_N_Op_Rem (N); - when N_Op_Rotate_Left => - Expand_N_Op_Rotate_Left (N); + when N_Op_Rotate_Left => + Expand_N_Op_Rotate_Left (N); - when N_Op_Rotate_Right => - Expand_N_Op_Rotate_Right (N); + when N_Op_Rotate_Right => + Expand_N_Op_Rotate_Right (N); - when N_Op_Shift_Left => - Expand_N_Op_Shift_Left (N); + when N_Op_Shift_Left => + Expand_N_Op_Shift_Left (N); - when N_Op_Shift_Right => - Expand_N_Op_Shift_Right (N); + when N_Op_Shift_Right => + Expand_N_Op_Shift_Right (N); - when N_Op_Shift_Right_Arithmetic => - Expand_N_Op_Shift_Right_Arithmetic (N); + when N_Op_Shift_Right_Arithmetic => + Expand_N_Op_Shift_Right_Arithmetic (N); - when N_Op_Subtract => - Expand_N_Op_Subtract (N); + when N_Op_Subtract => + Expand_N_Op_Subtract (N); - when N_Op_Xor => - Expand_N_Op_Xor (N); + when N_Op_Xor => + Expand_N_Op_Xor (N); - when N_Or_Else => - Expand_N_Or_Else (N); + when N_Or_Else => + Expand_N_Or_Else (N); - when N_Package_Body => - Expand_N_Package_Body (N); + when N_Package_Body => + Expand_N_Package_Body (N); - when N_Package_Declaration => - Expand_N_Package_Declaration (N); + when N_Package_Declaration => + Expand_N_Package_Declaration (N); - when N_Package_Renaming_Declaration => - Expand_N_Package_Renaming_Declaration (N); + when N_Package_Renaming_Declaration => + Expand_N_Package_Renaming_Declaration (N); - when N_Subprogram_Renaming_Declaration => - Expand_N_Subprogram_Renaming_Declaration (N); + when N_Subprogram_Renaming_Declaration => + Expand_N_Subprogram_Renaming_Declaration (N); - when N_Pragma => - Expand_N_Pragma (N); + when N_Pragma => + Expand_N_Pragma (N); - when N_Procedure_Call_Statement => - Expand_N_Procedure_Call_Statement (N); + when N_Procedure_Call_Statement => + Expand_N_Procedure_Call_Statement (N); - when N_Protected_Type_Declaration => - Expand_N_Protected_Type_Declaration (N); + when N_Protected_Type_Declaration => + Expand_N_Protected_Type_Declaration (N); - when N_Protected_Body => - Expand_N_Protected_Body (N); + when N_Protected_Body => + Expand_N_Protected_Body (N); - when N_Qualified_Expression => - Expand_N_Qualified_Expression (N); + when N_Qualified_Expression => + Expand_N_Qualified_Expression (N); - when N_Quantified_Expression => - Expand_N_Quantified_Expression (N); + when N_Quantified_Expression => + Expand_N_Quantified_Expression (N); - when N_Raise_Statement => - Expand_N_Raise_Statement (N); + when N_Raise_Statement => + Expand_N_Raise_Statement (N); - when N_Raise_Constraint_Error => - Expand_N_Raise_Constraint_Error (N); + when N_Raise_Constraint_Error => + Expand_N_Raise_Constraint_Error (N); - when N_Raise_Expression => - Expand_N_Raise_Expression (N); + when N_Raise_Expression => + Expand_N_Raise_Expression (N); - when N_Raise_Program_Error => - Expand_N_Raise_Program_Error (N); + when N_Raise_Program_Error => + Expand_N_Raise_Program_Error (N); - when N_Raise_Storage_Error => - Expand_N_Raise_Storage_Error (N); + when N_Raise_Storage_Error => + Expand_N_Raise_Storage_Error (N); - when N_Real_Literal => - Expand_N_Real_Literal (N); + when N_Real_Literal => + Expand_N_Real_Literal (N); - when N_Record_Representation_Clause => - Expand_N_Record_Representation_Clause (N); + when N_Record_Representation_Clause => + Expand_N_Record_Representation_Clause (N); - when N_Requeue_Statement => - Expand_N_Requeue_Statement (N); + when N_Requeue_Statement => + Expand_N_Requeue_Statement (N); - when N_Simple_Return_Statement => - Expand_N_Simple_Return_Statement (N); + when N_Simple_Return_Statement => + Expand_N_Simple_Return_Statement (N); - when N_Selected_Component => - Expand_N_Selected_Component (N); + when N_Selected_Component => + Expand_N_Selected_Component (N); - when N_Selective_Accept => - Expand_N_Selective_Accept (N); + when N_Selective_Accept => + Expand_N_Selective_Accept (N); - when N_Single_Task_Declaration => - Expand_N_Single_Task_Declaration (N); + when N_Single_Task_Declaration => + Expand_N_Single_Task_Declaration (N); - when N_Slice => - Expand_N_Slice (N); + when N_Slice => + Expand_N_Slice (N); - when N_Subtype_Indication => - Expand_N_Subtype_Indication (N); + when N_Subtype_Indication => + Expand_N_Subtype_Indication (N); - when N_Subprogram_Body => - Expand_N_Subprogram_Body (N); + when N_Subprogram_Body => + Expand_N_Subprogram_Body (N); - when N_Subprogram_Body_Stub => - Expand_N_Subprogram_Body_Stub (N); + when N_Subprogram_Body_Stub => + Expand_N_Subprogram_Body_Stub (N); - when N_Subprogram_Declaration => - Expand_N_Subprogram_Declaration (N); + when N_Subprogram_Declaration => + Expand_N_Subprogram_Declaration (N); - when N_Task_Body => - Expand_N_Task_Body (N); + when N_Task_Body => + Expand_N_Task_Body (N); - when N_Task_Type_Declaration => - Expand_N_Task_Type_Declaration (N); + when N_Task_Type_Declaration => + Expand_N_Task_Type_Declaration (N); - when N_Timed_Entry_Call => - Expand_N_Timed_Entry_Call (N); + when N_Timed_Entry_Call => + Expand_N_Timed_Entry_Call (N); - when N_Type_Conversion => - Expand_N_Type_Conversion (N); + when N_Type_Conversion => + Expand_N_Type_Conversion (N); - when N_Unchecked_Expression => - Expand_N_Unchecked_Expression (N); + when N_Unchecked_Expression => + Expand_N_Unchecked_Expression (N); - when N_Unchecked_Type_Conversion => - Expand_N_Unchecked_Type_Conversion (N); + when N_Unchecked_Type_Conversion => + Expand_N_Unchecked_Type_Conversion (N); - when N_Variant_Part => - Expand_N_Variant_Part (N); + when N_Variant_Part => + Expand_N_Variant_Part (N); -- For all other node kinds, no expansion activity required - when others => - null; + when others => + null; - end case; - end if; + end case; exception when RE_Not_Available => diff --git a/main/gcc/ada/expect.c b/main/gcc/ada/expect.c index aa014a6a381..45e0540e839 100644 --- a/main/gcc/ada/expect.c +++ b/main/gcc/ada/expect.c @@ -148,7 +148,11 @@ __gnat_pipe (int *fd) } int -__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +__gnat_expect_poll (int *fd, + int num_fd, + int timeout, + int *dead_process, + int *is_set) { #define MAX_DELAY 100 @@ -156,6 +160,8 @@ __gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) DWORD avail; HANDLE handles[num_fd]; + *dead_process = 0; + for (i = 0; i < num_fd; i++) is_set[i] = 0; @@ -174,8 +180,10 @@ __gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) for (i = 0; i < num_fd; i++) { if (!PeekNamedPipe (handles [i], NULL, 0, NULL, &avail, NULL)) - return -1; - + { + *dead_process = i + 1; + return -1; + } if (avail > 0) { is_set[i] = 1; @@ -245,7 +253,11 @@ __gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) } int -__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +__gnat_expect_poll (int *fd, + int num_fd, + int timeout, + int *dead_process, + int *is_set) { int i, num, ready = 0; unsigned int status; @@ -258,6 +270,8 @@ __gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) } iosb; char buf [256]; + *dead_process = 0; + for (i = 0; i < num_fd; i++) is_set[i] = 0; @@ -279,8 +293,9 @@ __gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) if ((status & 1) != 1) { - ready = -1; - return ready; + ready = -1; + dead_process = i + 1; + return ready; } } } @@ -395,7 +410,11 @@ __gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[]) } int -__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) +__gnat_expect_poll (int *fd, + int num_fd, + int timeout, + int *dead_process, + int *is_set) { struct timeval tv; SELECT_MASK rset; @@ -406,6 +425,8 @@ __gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) int i; int received; + *dead_process = 0; + tv.tv_sec = timeout / 1000; tv.tv_usec = (timeout % 1000) * 1000; @@ -458,6 +479,7 @@ __gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set) if (ei.request == TIOCCLOSE) { ioctl (fd[i], TIOCREQSET, &ei); + dead_process = i + 1; return -1; } @@ -510,10 +532,12 @@ __gnat_expect_portable_execvp (int *pid ATTRIBUTE_UNUSED, int __gnat_expect_poll (int *fd ATTRIBUTE_UNUSED, - int num_fd ATTRIBUTE_UNUSED, - int timeout ATTRIBUTE_UNUSED, - int *is_set ATTRIBUTE_UNUSED) + int num_fd ATTRIBUTE_UNUSED, + int timeout ATTRIBUTE_UNUSED, + int *dead_process ATTRIBUTE_UNUSED, + int *is_set ATTRIBUTE_UNUSED) { + *dead_process = 0; return -1; } #endif diff --git a/main/gcc/ada/fe.h b/main/gcc/ada/fe.h index f5554f866a1..fcd2f153324 100644 --- a/main/gcc/ada/fe.h +++ b/main/gcc/ada/fe.h @@ -55,8 +55,7 @@ extern char Fold_Lower[], Fold_Upper[]; #define Debug_Flag_NN debug__debug_flag_nn extern Boolean Debug_Flag_NN; -/* einfo: We will be setting Esize for types, Component_Bit_Offset for fields, - Alignment for types and objects, Component_Size for array types. */ +/* einfo: */ #define Set_Alignment einfo__set_alignment #define Set_Component_Bit_Offset einfo__set_component_bit_offset @@ -155,11 +154,6 @@ extern void Get_External_Name (Entity_Id, Boolean, String_Pointer); extern Boolean Is_Fully_Repped_Tagged_Type (Entity_Id); -/* exp_vfpt: */ - -#define Get_Vax_Real_Literal_As_Signed exp_vfpt__get_vax_real_literal_as_signed -extern Ureal Get_Vax_Real_Literal_As_Signed (Node_Id); - /* lib: */ #define Cunit lib__cunit @@ -174,20 +168,24 @@ extern Boolean In_Same_Source_Unit (Node_Id, Node_Id); /* opt: */ +#define Back_End_Inlining opt__back_end_inlining #define Exception_Extra_Info opt__exception_extra_info #define Exception_Locations_Suppressed opt__exception_locations_suppressed #define Exception_Mechanism opt__exception_mechanism -#define Generate_SCO_Instance_Table opt__generate_sco_instance_table #define Float_Format opt__float_format +#define Generate_SCO_Instance_Table opt__generate_sco_instance_table +#define GNAT_Mode opt__gnat_mode #define List_Representation_Info opt__list_representation_info typedef enum {Setjmp_Longjmp, Back_End_Exceptions} Exception_Mechanism_Type; +extern Boolean Back_End_Inlining; extern Boolean Exception_Extra_Info; extern Boolean Exception_Locations_Suppressed; extern Exception_Mechanism_Type Exception_Mechanism; -extern Boolean Generate_SCO_Instance_Table; extern Char Float_Format; +extern Boolean Generate_SCO_Instance_Table; +extern Boolean GNAT_Mode; extern Int List_Representation_Info; /* restrict: */ @@ -202,6 +200,11 @@ extern void Check_No_Implicit_Heap_Alloc (Node_Id); extern void Check_Elaboration_Code_Allowed (Node_Id); extern void Check_Implicit_Dynamic_Code_Allowed (Node_Id); +/* sem_aggr: */ +#define Is_Others_Aggregate sem_aggr__is_others_aggregate + +extern Boolean Is_Others_Aggregate (Node_Id); + /* sem_aux: */ #define Ancestor_Subtype sem_aux__ancestor_subtype diff --git a/main/gcc/ada/fname-uf.adb b/main/gcc/ada/fname-uf.adb index e3a731fefae..7bf27dbe22b 100644 --- a/main/gcc/ada/fname-uf.adb +++ b/main/gcc/ada/fname-uf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Krunch; with Opt; use Opt; with Osint; use Osint; with Table; -with Targparm; use Targparm; with Uname; use Uname; with Widechar; use Widechar; @@ -410,8 +409,7 @@ package body Fname.UF is (Name_Buffer, Name_Len, Integer (Maximum_File_Name_Length), - Debug_Flag_4, - OpenVMS_On_Target); + Debug_Flag_4); -- Replace extension diff --git a/main/gcc/ada/fname.adb b/main/gcc/ada/fname.adb index 48cb207054c..0bea5a0ba18 100644 --- a/main/gcc/ada/fname.adb +++ b/main/gcc/ada/fname.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 @@ ------------------------------------------------------------------------------ with Alloc; -with Hostparm; use Hostparm; with Table; -with Types; use Types; +with Types; use Types; package body Fname is @@ -78,13 +77,6 @@ package body Fname is then return True; - elsif OpenVMS - and then - (Name_Buffer (1 .. 4) = "dec-" - or else Name_Buffer (1 .. 8) = "dec ") - then - return True; - else return False; end if; diff --git a/main/gcc/ada/fname.ads b/main/gcc/ada/fname.ads index 74523c098ee..79c84c6cc8a 100644 --- a/main/gcc/ada/fname.ads +++ b/main/gcc/ada/fname.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +83,7 @@ package Fname is (Fname : File_Name_Type; Renamings_Included : Boolean := True) return Boolean; -- Similar to Is_Predefined_File_Name. The internal file set is a superset - -- of the predefined file set including children of GNAT, and also children - -- of DEC for the VMS case. + -- of the predefined file set including children of GNAT. procedure Tree_Read; -- Dummy procedure (reads dummy table values from tree file) diff --git a/main/gcc/ada/freeze.adb b/main/gcc/ada/freeze.adb index bf678b6aa2a..17f96491c38 100644 --- a/main/gcc/ada/freeze.adb +++ b/main/gcc/ada/freeze.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Debug; use Debug; @@ -105,6 +106,12 @@ package body Freeze is -- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order -- attribute definition clause. + 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 + -- to deferred constants without completion. We report this at the freeze + -- point of the function, to provide a better error message. + 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 @@ -180,6 +187,14 @@ package body Freeze is -- 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 + -- will be set appropriately. Note that an explicit occurrence of aspect + -- Scalar_Storage_Order or an explicit setting of this aspect with an + -- attribute definition clause occurs, then these two flags are reset in + -- any case, so call will have no effect. + procedure Undelay_Type (T : Entity_Id); -- T is a type of a component that we know to be an Itype. We don't want -- this to have a Freeze_Node, so ensure it doesn't. Do the same for any @@ -1225,6 +1240,57 @@ package body Freeze is end if; end Check_Debug_Info_Needed; + ------------------------------- + -- Check_Expression_Function -- + ------------------------------- + + 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 + + ------------------- + -- Find_Constant -- + ------------------- + + function Find_Constant (Nod : Node_Id) return Traverse_Result is + begin + -- When a constant is initialized with the result of a dispatching + -- call, the constant declaration is rewritten as a renaming of the + -- displaced function result. This scenario is not a premature use of + -- a constant even though the Has_Completion flag is not set. + + if Is_Entity_Name (Nod) + and then Present (Entity (Nod)) + and then Ekind (Entity (Nod)) = E_Constant + and then Scope (Entity (Nod)) = Current_Scope + and then Nkind (Declaration_Node (Entity (Nod))) = + N_Object_Declaration + and then not Is_Imported (Entity (Nod)) + and then not Has_Completion (Entity (Nod)) + then + Error_Msg_NE + ("premature use of& in call or instance", N, Entity (Nod)); + end if; + + return OK; + end Find_Constant; + + procedure Check_Deferred is new Traverse_Proc (Find_Constant); + + -- Start of processing for Check_Expression_Function + + begin + Decl := Original_Node (Unit_Declaration_Node (Nam)); + + if Scope (Nam) = Current_Scope + and then Nkind (Decl) = N_Expression_Function + then + Check_Deferred (Expression (Decl)); + end if; + end Check_Expression_Function; + ---------------------------- -- Check_Strict_Alignment -- ---------------------------- @@ -1733,7 +1799,12 @@ package body Freeze is procedure Freeze_Before (N : Node_Id; T : Entity_Id) is Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); + begin + if Ekind (T) = E_Function then + Check_Expression_Function (N, T); + end if; + if Is_Non_Empty_List (Freeze_Nodes) then Insert_Actions (N, Freeze_Nodes); end if; @@ -1744,13 +1815,18 @@ package body Freeze is ------------------- function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + Comp : Entity_Id; + F_Node : Node_Id; + Indx : Node_Id; + Formal : Entity_Id; + Atype : Entity_Id; + Test_E : Entity_Id := E; - Comp : Entity_Id; - F_Node : Node_Id; - Indx : Node_Id; - Formal : Entity_Id; - Atype : Entity_Id; + -- This could use a comment ??? + + 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 @@ -1786,6 +1862,20 @@ package body Freeze is -- Freeze record type, including freezing component types, and freezing -- primitive operations if this is a tagged type. + function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean; + -- 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 Wrap_Imported_Subprogram (E : Entity_Id); -- If E is an entity for an imported subprogram with pre/post-conditions -- then this procedure will create a wrapper to ensure that proper run- @@ -1810,6 +1900,7 @@ package body Freeze is function After_Last_Declaration return Boolean is Spec : constant Node_Id := Parent (Current_Scope); + begin if Nkind (Spec) = N_Package_Specification then if Present (Private_Declarations (Spec)) then @@ -1819,6 +1910,7 @@ package body Freeze is else return False; end if; + else return False; end if; @@ -1938,8 +2030,7 @@ package body Freeze is else Error_Msg_N ("current instance must be an immutably limited " - & "type (RM-2012, 7.5 (8.1/3))", - Prefix (N)); + & "type (RM-2012, 7.5 (8.1/3))", Prefix (N)); end if; return Abandon; @@ -2076,6 +2167,10 @@ package body Freeze is if Ekind (Arr) = E_Array_Type then + -- Deal with default setting of reverse storage order + + Set_SSO_From_Default (Arr); + -- Propagate flags for component type if Is_Controlled (Component_Type (Arr)) @@ -2103,8 +2198,7 @@ package body Freeze is Error_Msg_Name_1 := CN; Error_Msg_Sloc := Sloc (Arr); Error_Msg_N - ("pragma Pack affects convention % components #??", - PP); + ("pragma Pack affects convention % components #??", PP); Error_Msg_Name_1 := CN; Error_Msg_N ("\array components may not have % compatible " @@ -2181,6 +2275,7 @@ package body Freeze is Comp_Size_C : constant Node_Id := Get_Attribute_Definition_Clause (Ent, Attribute_Component_Size); + begin -- Warn if we have pack and component size so that the -- pack is ignored. @@ -2219,19 +2314,18 @@ package body Freeze is if Has_Pragma_Pack (Arr) and then not Present (Comp_Size_C) - and then - (Csiz = 7 or else Csiz = 15 or else Csiz = 31) + and then (Csiz = 7 or else Csiz = 15 or else Csiz = 31) and then Esize (Base_Type (Ctyp)) = Csiz + 1 then Error_Msg_Uint_1 := Csiz; if Present (Pack_Pragma) then Error_Msg_N - ("??pragma Pack causes component size " - & "to be ^!", Pack_Pragma); + ("??pragma Pack causes component size to be ^!", + Pack_Pragma); Error_Msg_N - ("\??use Component_Size to set " - & "desired value!", Pack_Pragma); + ("\??use Component_Size to set desired value!", + Pack_Pragma); end if; end if; @@ -2262,8 +2356,7 @@ package body Freeze is if Known_Static_Esize (Component_Type (Arr)) and then Esize (Component_Type (Arr)) = Csiz then - Set_Has_Non_Standard_Rep - (Base_Type (Arr), False); + Set_Has_Non_Standard_Rep (Base_Type (Arr), False); end if; -- In all other cases, packing is indeed needed @@ -2454,8 +2547,7 @@ package body Freeze is Ilen := Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Ityp, Loc), + Prefix => New_Occurrence_Of (Ityp, Loc), Attribute_Name => Name_Range_Length); Analyze_And_Resolve (Ilen); @@ -2485,10 +2577,8 @@ package body Freeze is if Known_RM_Size (Arr) then declare - SizC : constant Node_Id := Size_Clause (Arr); - + SizC : constant Node_Id := Size_Clause (Arr); Discard : Boolean; - pragma Warnings (Off, Discard); begin -- It is not clear if it is possible to have no size clause @@ -2597,10 +2687,10 @@ package body Freeze is ------------------------ procedure Freeze_Record_Type (Rec : Entity_Id) is + ADC : Node_Id; Comp : Entity_Id; IR : Node_Id; Prev : Entity_Id; - ADC : Node_Id; Junk : Boolean; pragma Warnings (Off, Junk); @@ -2983,6 +3073,7 @@ package body Freeze is if Will_Be_Frozen then Undelay_Type (Comp); + else if Present (Prev) then Set_Next_Entity (Prev, Next_Entity (Comp)); @@ -3030,8 +3121,8 @@ package body Freeze is if Is_Entity_Name (Expression (Alloc)) then Freeze_And_Append (Entity (Expression (Alloc)), N, Result); - elsif - Nkind (Expression (Alloc)) = N_Subtype_Indication + + elsif Nkind (Expression (Alloc)) = N_Subtype_Indication then Freeze_And_Append (Entity (Subtype_Mark (Expression (Alloc))), @@ -3053,18 +3144,56 @@ package body Freeze is then Check_Itype (Etype (Comp)); + -- Freeze the designated type when initializing a component with + -- an aggregate in case the aggregate contains allocators. + + -- type T is ...; + -- type T_Ptr is access all T; + -- type T_Array is array ... of T_Ptr; + + -- type Rec is record + -- Comp : T_Array := (others => ...); + -- end record; + elsif Is_Array_Type (Etype (Comp)) and then Is_Access_Type (Component_Type (Etype (Comp))) - and then Present (Parent (Comp)) - and then Nkind (Parent (Comp)) = N_Component_Declaration - and then Present (Expression (Parent (Comp))) - and then Nkind (Expression (Parent (Comp))) = N_Aggregate - and then Is_Fully_Defined - (Designated_Type (Component_Type (Etype (Comp)))) then - Freeze_And_Append - (Designated_Type - (Component_Type (Etype (Comp))), N, Result); + declare + Comp_Par : constant Node_Id := Parent (Comp); + Desig_Typ : constant Entity_Id := + Designated_Type + (Component_Type (Etype (Comp))); + + begin + -- The only case when this sort of freezing is not done is + -- when the designated type is class-wide and the root type + -- is the record owning the component. This scenario results + -- in a circularity because the class-wide type requires + -- primitives that have not been created yet as the root + -- type is in the process of being frozen. + + -- type Rec is tagged; + -- type Rec_Ptr is access all Rec'Class; + -- type Rec_Array is array ... of Rec_Ptr; + + -- type Rec is record + -- Comp : Rec_Array := (others => ...); + -- end record; + + if Is_Class_Wide_Type (Desig_Typ) + and then Root_Type (Desig_Typ) = Rec + then + null; + + elsif Is_Fully_Defined (Desig_Typ) + and then Present (Comp_Par) + and then Nkind (Comp_Par) = N_Component_Declaration + and then Present (Expression (Comp_Par)) + and then Nkind (Expression (Comp_Par)) = N_Aggregate + then + Freeze_And_Append (Desig_Typ, N, Result); + end if; + end; end if; Prev := Comp; @@ -3091,6 +3220,12 @@ package body Freeze is end loop; end; + -- Deal with default setting of reverse storage order + + Set_SSO_From_Default (Rec); + + -- Now deal with reverse storage order/bit order issues + if Present (SSO_ADC) then -- Check compatibility of Scalar_Storage_Order with Bit_Order, if @@ -3129,10 +3264,8 @@ package body Freeze is if Present (ADC) and then Base_Type (Rec) = Rec then if not (Placed_Component - or else - Present (SSO_ADC) - or else - Is_Packed (Rec)) + or else Present (SSO_ADC) + or else Is_Packed (Rec)) then -- Warn if clause has no effect when no component clause is -- present, but suppress warning if the Bit_Order is required @@ -3144,7 +3277,7 @@ 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. + -- for reversed bit order, when not using reverse SSO. elsif Reverse_Bit_Order (Rec) and then not Reverse_Storage_Order (Rec) @@ -3280,8 +3413,7 @@ package body Freeze is while Present (Comp) loop if Present (Component_Clause (Comp)) and then (Is_Fixed_Point_Type (Etype (Comp)) - or else - Is_Bit_Packed_Array (Etype (Comp))) + or else Is_Bit_Packed_Array (Etype (Comp))) then Check_Size (Component_Name (Component_Clause (Comp)), @@ -3395,6 +3527,45 @@ package body Freeze is end if; end if; + -- The following checks are only relevant when SPARK_Mode is on as + -- they are not standard Ada legality rules. + + if SPARK_Mode = On then + if Is_Effectively_Volatile (Rec) then + + -- A discriminated type cannot be effectively volatile + -- (SPARK RM C.6(4)). + + if Has_Discriminants (Rec) then + Error_Msg_N ("discriminated type & cannot be volatile", Rec); + + -- A tagged type cannot be effectively volatile + -- (SPARK RM C.6(5)). + + elsif Is_Tagged_Type (Rec) then + Error_Msg_N ("tagged type & cannot be volatile", Rec); + end if; + + -- A non-effectively volatile record type cannot contain + -- effectively volatile components (SPARK RM C.6(2)). + + else + Comp := First_Component (Rec); + while Present (Comp) loop + if Comes_From_Source (Comp) + and then Is_Effectively_Volatile (Etype (Comp)) + then + Error_Msg_Name_1 := Chars (Rec); + Error_Msg_N + ("component & of non-volatile type % cannot be " + & "volatile", Comp); + end if; + + Next_Component (Comp); + end loop; + end if; + end if; + -- All done if not a full record definition if Ekind (Rec) /= E_Record_Type then @@ -3443,6 +3614,58 @@ package body Freeze is end Check_Variant_Part; end Freeze_Record_Type; + ------------------------------- + -- Has_Boolean_Aspect_Import -- + ------------------------------- + + function Has_Boolean_Aspect_Import (E : Entity_Id) return Boolean is + Decl : constant Node_Id := Declaration_Node (E); + Asp : Node_Id; + Expr : Node_Id; + + begin + if Has_Aspects (Decl) then + Asp := First (Aspect_Specifications (Decl)); + while Present (Asp) loop + Expr := Expression (Asp); + + -- The value of aspect Import is True when the expression is + -- either missing or it is explicitly set to True. + + if Get_Aspect_Id (Asp) = Aspect_Import + and then (No (Expr) + or else (Compile_Time_Known_Value (Expr) + and then Is_True (Expr_Value (Expr)))) + then + return True; + end if; + + Next (Asp); + end loop; + end if; + + return False; + end Has_Boolean_Aspect_Import; + + ---------------------------- + -- Late_Freeze_Subprogram -- + ---------------------------- + + procedure Late_Freeze_Subprogram (E : Entity_Id) is + Spec : constant Node_Id := + Specification (Unit_Declaration_Node (Scope (E))); + Decls : List_Id; + + begin + if Present (Private_Declarations (Spec)) then + Decls := Private_Declarations (Spec); + else + Decls := Visible_Declarations (Spec); + end if; + + Append_List (Result, Decls); + end Late_Freeze_Subprogram; + ------------------------------ -- Wrap_Imported_Subprogram -- ------------------------------ @@ -3511,8 +3734,7 @@ package body Freeze is -- Acquire copy of Inline pragma - Iprag := - Copy_Separate_Tree (Import_Pragma (E)); + Iprag := Copy_Separate_Tree (Import_Pragma (E)); -- Fix up spec to be not imported any more @@ -3629,8 +3851,12 @@ package body Freeze is then return No_List; - -- Generic types need no freeze node and have no delayed semantic - -- checks. + -- Formal subprograms are never frozen + + elsif Is_Formal_Subprogram (E) then + return No_List; + + -- Generic types are never frozen as they lack delayed semantic checks elsif Is_Generic_Type (E) then return No_List; @@ -3792,7 +4018,7 @@ package body Freeze is while Present (Formal) loop F_Type := Etype (Formal); - -- AI05-0151 : incomplete types can appear in a profile. + -- AI05-0151: incomplete types can appear in a profile. -- By the time the entity is frozen, the full view must -- be available, unless it is a limited view. @@ -3972,6 +4198,13 @@ 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); @@ -4000,6 +4233,7 @@ package body Freeze is Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type then Set_Is_Frozen (E, False); + Set_Returns_Limited_View (E); return Result; end if; @@ -4132,6 +4366,46 @@ package body Freeze is Freeze_Subprogram (E); end if; + if Late_Freezing then + Late_Freeze_Subprogram (E); + 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. + + if No_Return (E) + and then Warn_On_Suspicious_Contract + and then Present (Contract (E)) + then + declare + Prag : Node_Id := Pre_Post_Conditions (Contract (E)); + Exp : Node_Id; + + begin + while Present (Prag) loop + if Nam_In (Pragma_Name (Prag), Name_Post, + Name_Postcondition, + Name_Refined_Post) + then + Exp := + Expression + (First (Pragma_Argument_Associations (Prag))); + + if Nkind (Exp) /= N_Identifier + or else Chars (Exp) /= Name_False + then + Error_Msg_NE + ("useless postcondition, & is marked " + & "No_Return?T?", Exp, E); + end if; + end if; + + Prag := Next_Pragma (Prag); + end loop; + end; + end if; + -- Here for other than a subprogram or type else @@ -4241,12 +4515,12 @@ package body Freeze is if Has_Default_Initialization or else (Has_Init_Expression (Decl) - and then - (No (Expression (Decl)) - or else not - (Is_Static_Expression (Expression (Decl)) - or else - Nkind (Expression (Decl)) = N_Null))) + and then + (No (Expression (Decl)) + or else not + (Is_OK_Static_Expression (Expression (Decl)) + or else + Nkind (Expression (Decl)) = N_Null))) then Error_Msg_NE ("Thread_Local_Storage variable& is " @@ -4314,6 +4588,7 @@ package body Freeze is if Ekind (E) = E_Constant and then (Has_Volatile_Components (E) or else Is_Volatile (E)) and then not Is_Imported (E) + and then not Has_Boolean_Aspect_Import (E) then -- Make sure we actually have a pragma, and have not merely -- inherited the indication from elsewhere (e.g. an address @@ -4397,6 +4672,24 @@ package body Freeze is return No_List; end if; + -- Check for error of Type_Invariant'Class applied to an untagged + -- type (check delayed to freeze time when full type is available). + + declare + Prag : constant Node_Id := Get_Pragma (E, Pragma_Invariant); + begin + if Present (Prag) + and then Class_Present (Prag) + and then not Is_Tagged_Type (E) + then + Error_Msg_NE + ("Type_Invariant''Class cannot be specified for &", + Prag, E); + Error_Msg_N + ("\can only be specified for a tagged type", Prag); + end if; + end; + -- Deal with special cases of freezing for subtype if E /= Base_Type (E) then @@ -4692,12 +4985,11 @@ package body Freeze is then Freeze_Record_Type (E); - -- For a concurrent type, freeze corresponding record type. This - -- does not correspond to any specific rule in the RM, but the - -- record type is essentially part of the concurrent type. - -- Freeze as well all local entities. This includes record types - -- created for entry parameter blocks, and whatever local entities - -- may appear in the private part. + -- For a concurrent type, freeze corresponding record type. This does + -- not correspond to any specific rule in the RM, but the record type + -- is essentially part of the concurrent type. Also freeze all local + -- entities. This includes record types created for entry parameter + -- blocks and whatever local entities may appear in the private part. elsif Is_Concurrent_Type (E) then if Present (Corresponding_Record_Type (E)) then @@ -4710,13 +5002,19 @@ package body Freeze is Freeze_And_Append (Comp, N, Result); elsif (Ekind (Comp)) /= E_Function then - if Is_Itype (Etype (Comp)) - and then Underlying_Type (Scope (Etype (Comp))) = E - then - Undelay_Type (Etype (Comp)); - end if; - Freeze_And_Append (Etype (Comp), N, Result); + -- The guard on the presence of the Etype seems to be needed + -- for some CodePeer (-gnatcC) cases, but not clear why??? + + if Present (Etype (Comp)) then + if Is_Itype (Etype (Comp)) + and then Underlying_Type (Scope (Etype (Comp))) = E + then + Undelay_Type (Etype (Comp)); + end if; + + Freeze_And_Append (Etype (Comp), N, Result); + end if; end if; Next_Entity (Comp); @@ -4728,7 +5026,7 @@ package body Freeze is -- view, we can retrieve the full view, but not the reverse). -- However, in order to freeze correctly, we need to freeze the full -- view. If we are freezing at the end of a scope (or within the - -- scope of the private type), the partial and full views will have + -- scope) of the private type, the partial and full views will have -- been swapped, the full view appears first in the entity chain and -- the swapping mechanism ensures that the pointers are properly set -- (on scope exit). @@ -4738,6 +5036,11 @@ package body Freeze is -- set the pointers appropriately since we cannot rely on swapping to -- fix things up (subtypes in an outer scope might not get swapped). + -- If the full view is itself private, the above requirements apply + -- to the underlying full view instead of the full view. But there is + -- no swapping mechanism for the underlying full view so we need to + -- set the pointers appropriately in both cases. + elsif Is_Incomplete_Or_Private_Type (E) and then not Is_Generic_Type (E) then @@ -4776,29 +5079,45 @@ package body Freeze is if Is_Frozen (Full_View (E)) then Set_Has_Delayed_Freeze (E, False); Set_Freeze_Node (E, Empty); - Check_Debug_Info_Needed (E); -- Otherwise freeze full view and patch the pointers so that - -- the freeze node will elaborate both views in the back-end. + -- the freeze node will elaborate both views in the back end. + -- However, if full view is itself private, freeze underlying + -- full view instead and patch the pointers so that the freeze + -- node will elaborate the three views in the back end. else declare - Full : constant Entity_Id := Full_View (E); + Full : Entity_Id := Full_View (E); begin if Is_Private_Type (Full) and then Present (Underlying_Full_View (Full)) then - Freeze_And_Append - (Underlying_Full_View (Full), N, Result); + Full := Underlying_Full_View (Full); end if; Freeze_And_Append (Full, N, Result); - if Has_Delayed_Freeze (E) then + if Full /= Full_View (E) + and then Has_Delayed_Freeze (Full_View (E)) + then 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)); + + else + Set_Has_Delayed_Freeze (Full_View (E), False); + Set_Freeze_Node (Full_View (E), Empty); + end if; + end if; + + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Full_View (E)); + + if Present (F_Node) then Set_Freeze_Node (E, F_Node); Set_Entity (F_Node, E); @@ -4811,10 +5130,10 @@ package body Freeze is end if; end if; end; - - Check_Debug_Info_Needed (E); end if; + Check_Debug_Info_Needed (E); + -- AI-117 requires that the convention of a partial view be the -- same as the convention of the full view. Note that this is a -- recognized breach of privacy, but it's essential for logical @@ -4841,6 +5160,35 @@ package body Freeze is return Result; + -- Case of underlying full view present + + elsif Is_Private_Type (E) + and then Present (Underlying_Full_View (E)) + then + if not Is_Frozen (Underlying_Full_View (E)) then + Freeze_And_Append (Underlying_Full_View (E), N, Result); + end if; + + -- Patch the pointers so that the freeze node will elaborate + -- both views in the back end. + + if Has_Delayed_Freeze (E) then + F_Node := Freeze_Node (Underlying_Full_View (E)); + + if Present (F_Node) then + Set_Freeze_Node (E, F_Node); + Set_Entity (F_Node, E); + + else + Set_Has_Delayed_Freeze (E, False); + Set_Freeze_Node (E, Empty); + end if; + end if; + + Check_Debug_Info_Needed (E); + + return Result; + -- Case of no full view present. If entity is derived or subtype, -- it is safe to freeze, correctness depends on the frozen status -- of parent. Otherwise it is either premature usage, or a Taft @@ -5398,7 +5746,7 @@ package body Freeze is Analyze_And_Resolve (Exp, Typ); if Etype (Exp) /= Any_Type then - if not Is_Static_Expression (Exp) then + if not Is_OK_Static_Expression (Exp) then Error_Msg_Name_1 := Nam; Flag_Non_Static_Expr ("aspect% requires static expression", Exp); @@ -5647,21 +5995,21 @@ package body Freeze is -- expression, see section "Handling of Default Expressions" in the -- spec of package Sem for further details. Note that we have to make -- sure that we actually have a real expression (if we have a subtype - -- indication, we can't test Is_Static_Expression). However, we exclude - -- the case of the prefix of an attribute of a static scalar subtype - -- from this early return, because static subtype attributes should - -- always cause freezing, even in default expressions, but the attribute - -- may not have been marked as static yet (because in Resolve_Attribute, - -- the call to Eval_Attribute follows the call of Freeze_Expression on - -- the prefix). + -- indication, we can't test Is_OK_Static_Expression). However, we + -- exclude the case of the prefix of an attribute of a static scalar + -- subtype from this early return, because static subtype attributes + -- should always cause freezing, even in default expressions, but + -- the attribute may not have been marked as static yet (because in + -- Resolve_Attribute, the call to Eval_Attribute follows the call of + -- Freeze_Expression on the prefix). if In_Spec_Exp and then Nkind (N) in N_Subexpr - and then not Is_Static_Expression (N) + and then not Is_OK_Static_Expression (N) and then (Nkind (Parent (N)) /= N_Attribute_Reference or else not (Is_Entity_Name (N) and then Is_Type (Entity (N)) - and then Is_Static_Subtype (Entity (N)))) + and then Is_OK_Static_Subtype (Entity (N)))) then return; end if; @@ -5697,6 +6045,11 @@ package body Freeze is or else not Comes_From_Source (Entity (N))) then Nam := Entity (N); + + if Present (Nam) and then Ekind (Nam) = E_Function then + Check_Expression_Function (N, Nam); + end if; + else Nam := Empty; end if; @@ -5766,12 +6119,12 @@ package body Freeze is return; end if; - -- Loop for looking at the right place to insert the freeze nodes, - -- exiting from the loop when it is appropriate to insert the freeze - -- node before the current node P. - - -- Also checks some special exceptions to the freezing rules. These - -- cases result in a direct return, bypassing the freeze action. + -- Examine the enclosing context by climbing the parent chain. The + -- traversal serves two purposes - to detect scenarios where freezeing + -- is not needed and to find the proper insertion point for the freeze + -- nodes. Although somewhat similar to Insert_Actions, this traversal + -- is freezing semantics-sensitive. Inserting freeze nodes blindly in + -- the tree may result in types being frozen too early. P := N; loop @@ -5975,13 +6328,26 @@ package body Freeze is exit when Is_List_Member (P); - -- Note: The N_Loop_Statement is a special case. A type that - -- appears in the source can never be frozen in a loop (this - -- occurs only because of a loop expanded by the expander), so we - -- keep on going. Otherwise we terminate the search. Same is true - -- of any entity which comes from source. (if they have predefined - -- type, that type does not appear to come from source, but the - -- entity should not be frozen here). + -- Freeze nodes produced by an expression coming from the Actions + -- list of a N_Expression_With_Actions node must remain within the + -- Actions list. Inserting the freeze nodes further up the tree + -- may lead to use before declaration issues in the case of array + -- types. + + when N_Expression_With_Actions => + if Is_List_Member (P) + and then List_Containing (P) = Actions (Parent_P) + then + exit; + end if; + + -- Note: N_Loop_Statement is a special case. A type that appears + -- in the source can never be frozen in a loop (this occurs only + -- because of a loop expanded by the expander), so we keep on + -- going. Otherwise we terminate the search. Same is true of any + -- entity which comes from source. (if they have predefined type, + -- that type does not appear to come from source, but the entity + -- should not be frozen here). when N_Loop_Statement => exit when not Comes_From_Source (Etype (N)) @@ -6607,7 +6973,7 @@ package body Freeze is begin Ensure_Type_Is_SA (Etype (N)); - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then return; elsif Nkind (N) = N_Identifier then @@ -6816,11 +7182,7 @@ package body Freeze is else Set_Mechanisms (E); - -- For foreign conventions, warn about return of an - -- unconstrained array. - - -- Note: we *do* allow a return by descriptor for the VMS case, - -- though here there is probably more to be done ??? + -- For foreign conventions, warn about return of unconstrained array if Ekind (E) = E_Function then Retype := Underlying_Type (Etype (E)); @@ -6843,11 +7205,6 @@ package body Freeze is elsif Is_Array_Type (Retype) and then not Is_Constrained (Retype) - -- Exclude cases where descriptor mechanism is set, since the - -- VMS descriptor mechanisms allow such unconstrained returns. - - and then Mechanism (E) not in Descriptor_Codes - -- Check appropriate warning is enabled (should we check for -- Warnings (Off) on specific entities here, probably so???) @@ -6885,39 +7242,6 @@ package body Freeze is end if; end if; - -- For VMS, descriptor mechanisms for parameters are allowed only for - -- imported/exported subprograms. Moreover, the NCA descriptor is not - -- allowed for parameters of exported subprograms. - - if OpenVMS_On_Target then - if Is_Exported (E) then - F := First_Formal (E); - while Present (F) loop - if Mechanism (F) = By_Descriptor_NCA then - Error_Msg_N - ("'N'C'A' descriptor for parameter not permitted", F); - Error_Msg_N - ("\can only be used for imported subprogram", F); - end if; - - Next_Formal (F); - end loop; - - elsif not Is_Imported (E) then - F := First_Formal (E); - while Present (F) loop - if Mechanism (F) in Descriptor_Codes then - Error_Msg_N - ("descriptor mechanism for parameter not permitted", F); - Error_Msg_N - ("\can only be used for imported/exported subprogram", F); - end if; - - Next_Formal (F); - end loop; - end if; - end if; - -- Pragma Inline_Always is disallowed for dispatching subprograms -- because the address of such subprograms is saved in the dispatch -- table to support dispatching calls, and dispatching calls cannot @@ -7053,9 +7377,8 @@ package body Freeze is or else Nkind_In (Dcopy, N_Expanded_Name, N_Integer_Literal, N_Character_Literal, - N_String_Literal) - or else (Nkind (Dcopy) = N_Real_Literal - and then not Vax_Float (Etype (Dcopy))) + N_String_Literal, + N_Real_Literal) or else (Nkind (Dcopy) = N_Attribute_Reference and then Attribute_Name (Dcopy) = Name_Null_Parameter) or else Known_Null (Dcopy) @@ -7168,6 +7491,45 @@ package body Freeze is end if; end Set_Component_Alignment_If_Not_Set; + -------------------------- + -- Set_SSO_From_Default -- + -------------------------- + + procedure Set_SSO_From_Default (T : Entity_Id) is + begin + if (Is_Record_Type (T) or else Is_Array_Type (T)) + and then Is_Base_Type (T) + then + if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T)) + or else + ((not Bytes_Big_Endian) and then SSO_Set_High_By_Default (T))) + + -- For a record type, if native bit order is specified explicitly, + -- then never set reverse SSO from default. + + and then not + (Is_Record_Type (T) + and then Has_Rep_Item (T, Name_Bit_Order) + and then not Reverse_Bit_Order (T)) + then + -- If flags cause reverse storage order, then set the result. Note + -- that we would have ignored the pragma setting the non default + -- storage order in any case, hence the assertion at this point. + + pragma Assert (Support_Nondefault_SSO_On_Target); + Set_Reverse_Storage_Order (T); + + -- For a record type, also set reversed bit order. Note that if + -- a bit order has been specified explicitly, then this is a + -- no-op, as per the guard above. + + if Is_Record_Type (T) then + Set_Reverse_Bit_Order (T); + end if; + end if; + end if; + end Set_SSO_From_Default; + ------------------ -- Undelay_Type -- ------------------ diff --git a/main/gcc/ada/frontend.adb b/main/gcc/ada/frontend.adb index 24b33cfe209..5cea4dbba6a 100644 --- a/main/gcc/ada/frontend.adb +++ b/main/gcc/ada/frontend.adb @@ -57,7 +57,6 @@ with Sem_Ch8; use Sem_Ch8; with Sem_SCIL; with Sem_Elab; use Sem_Elab; with Sem_Prag; use Sem_Prag; -with Sem_VFpt; use Sem_VFpt; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -144,11 +143,13 @@ begin Prag : Node_Id; + Temp_File : Boolean; + begin - -- We always analyze config files with style checks off, since - -- we don't want a miscellaneous gnat.adc that is around to - -- discombobulate intended -gnatg or -gnaty compilations. We - -- also disconnect checking for maximum line length. + -- We always analyze config files with style checks off, since we + -- don't want a miscellaneous gnat.adc that is around to discombobulate + -- intended -gnatg or -gnaty compilations. We also disconnect checking + -- for maximum line length. Opt.Style_Check := False; Style_Check := False; @@ -164,9 +165,23 @@ begin Name_Len := 8; Source_gnat_adc := Load_Config_File (Name_Enter); + -- Case of gnat.adc file present + if Source_gnat_adc /= No_Source_File then + + -- Parse the gnat.adc file for configuration pragmas + Initialize_Scanner (No_Unit, Source_gnat_adc); Config_Pragmas := Par (Configuration_Pragmas => True); + + -- We unconditionally add a compilation dependency for gnat.adc + -- so that if it changes, we force a recompilation. This is a + -- fairly recent (2014-03-28) change. + + Prepcomp.Add_Dependency (Source_gnat_adc); + + -- Case of no gnat.adc file present + else Config_Pragmas := Empty_List; end if; @@ -175,35 +190,46 @@ begin Config_Pragmas := Empty_List; end if; - -- Check for VAX Float - - if Targparm.VAX_Float_On_Target then - - -- pragma Float_Representation (VAX_Float); + -- Now deal with specified config pragmas files if there are any - Opt.Float_Format := 'V'; + if Opt.Config_File_Names /= null then - -- pragma Long_Float (G_Float); + -- Loop through config pragmas files - Opt.Float_Format_Long := 'G'; + for Index in Opt.Config_File_Names'Range loop - Set_Standard_Fpt_Formats; - end if; + -- See if extension is .TMP/.tmp indicating a temporary config + -- file (which we ignore from the dependency point of view). - -- Now deal with specified config pragmas files if there are any - - if Opt.Config_File_Names /= null then - for Index in Opt.Config_File_Names'Range loop Name_Len := Config_File_Names (Index)'Length; Name_Buffer (1 .. Name_Len) := Config_File_Names (Index).all; + Temp_File := + Name_Len > 4 + and then + (Name_Buffer (Name_Len - 3 .. Name_Len) = ".TMP" + or else + Name_Buffer (Name_Len - 3 .. Name_Len) = ".tmp"); + + -- Load the file, error if we did not find it + Source_Config_File := Load_Config_File (Name_Enter); if Source_Config_File = No_Source_File then Osint.Fail ("cannot find configuration pragmas file " & Config_File_Names (Index).all); + + -- If we did find the file, and it is not a temporary file, then + -- we unconditionally add a compilation dependency for it so + -- that if it changes, we force a recompilation. This is a + -- fairly recent (2014-03-28) change. + + elsif not Temp_File then + Prepcomp.Add_Dependency (Source_Config_File); end if; + -- Parse the config pragmas file, and accumulate results + Initialize_Scanner (No_Unit, Source_Config_File); Append_List_To (Config_Pragmas, Par (Configuration_Pragmas => True)); @@ -235,6 +261,20 @@ begin Opt.Suppress_Options := Scope_Suppress; end; + -- If a target dependency info file has been read through switch -gnateT=, + -- add it to the dependencies. + + if Target_Dependent_Info_Read_Name /= null then + declare + Index : Source_File_Index; + begin + Name_Len := 0; + Add_Str_To_Name_Buffer (Target_Dependent_Info_Read_Name.all); + Index := Load_Config_File (Name_Enter); + Prepcomp.Add_Dependency (Index); + end; + end if; + -- This is where we can capture the value of the compilation unit specific -- restrictions that have been set by the config pragma files (or from -- Targparm), for later restoration when processing e.g. subunits. diff --git a/main/gcc/ada/g-alveop.ads b/main/gcc/ada/g-alveop.ads index eb4db79277d..351e450570a 100644 --- a/main/gcc/ada/g-alveop.ads +++ b/main/gcc/ada/g-alveop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -7884,12 +7884,12 @@ private -- Inlining considerations -- ----------------------------- - -- The intent in the Hard binding case is to eventually map operations - -- to hardware instructions. Needless to say, intermediate function calls - -- do not fit this purpose, so all the user visible subprograms shall be - -- inlined. In the soft case, the bulk of the work is performed by the - -- low level routines, and those exported by this unit are short enough - -- for the inlining to make sense and even be beneficial, so... + -- The intent in the Hard binding case is to eventually map operations to + -- hardware instructions. Needless to say, intermediate function calls do + -- not fit this purpose, so all the user visible subprograms are inlined. + -- In the soft case, the bulk of the work is performed by the low level + -- routines, and those exported by this unit are short enough for the + -- inlining to make sense and even be beneficial, so... pragma Inline_Always (vec_abs); pragma Inline_Always (vec_abss); diff --git a/main/gcc/ada/g-awk.adb b/main/gcc/ada/g-awk.adb index f2c934c2f25..6f58e46a584 100644 --- a/main/gcc/ada/g-awk.adb +++ b/main/gcc/ada/g-awk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -929,7 +929,6 @@ package body GNAT.AWK is if Callbacks in Only .. Pass_Through then declare Discard : Boolean; - pragma Unreferenced (Discard); begin Discard := Apply_Filters (Session); end; diff --git a/main/gcc/ada/g-calend.adb b/main/gcc/ada/g-calend.adb index 3b731e1eecd..8f309de7251 100644 --- a/main/gcc/ada/g-calend.adb +++ b/main/gcc/ada/g-calend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -29,8 +29,9 @@ -- -- ------------------------------------------------------------------------------ -package body GNAT.Calendar is +with Interfaces.C.Extensions; +package body GNAT.Calendar is use Ada.Calendar; use Interfaces; @@ -341,12 +342,12 @@ package body GNAT.Calendar is procedure timeval_to_duration (T : not null access timeval; - sec : not null access C.long; + sec : not null access C.Extensions.long_long; usec : not null access C.long); pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); Micro : constant := 10**6; - sec : aliased C.long; + sec : aliased C.Extensions.long_long; usec : aliased C.long; begin @@ -361,14 +362,14 @@ package body GNAT.Calendar is function To_Timeval (D : Duration) return timeval is procedure duration_to_timeval - (Sec : C.long; + (Sec : C.Extensions.long_long; Usec : C.long; T : not null access timeval); pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval"); Micro : constant := 10**6; Result : aliased timeval; - sec : C.long; + sec : C.Extensions.long_long; usec : C.long; begin @@ -376,7 +377,7 @@ package body GNAT.Calendar is sec := 0; usec := 0; else - sec := C.long (D - 0.5); + sec := C.Extensions.long_long (D - 0.5); usec := C.long ((D - Duration (sec)) * Micro - 0.5); end if; diff --git a/main/gcc/ada/g-calend.ads b/main/gcc/ada/g-calend.ads index b1c5a407155..4234061e724 100644 --- a/main/gcc/ada/g-calend.ads +++ b/main/gcc/ada/g-calend.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -162,7 +162,7 @@ private -- This is a dummy declaration that should be the largest possible timeval -- structure of all supported targets. - type timeval is array (1 .. 2) of Interfaces.C.long; + type timeval is array (1 .. 3) of Interfaces.C.long; function Julian_Day (Year : Ada.Calendar.Year_Number; diff --git a/main/gcc/ada/g-catiio.adb b/main/gcc/ada/g-catiio.adb index 2ab7622f305..c0ccb4b7961 100644 --- a/main/gcc/ada/g-catiio.adb +++ b/main/gcc/ada/g-catiio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -789,7 +789,6 @@ package body GNAT.Calendar.Time_IO is else declare Discard : Second_Duration; - pragma Unreferenced (Discard); begin Split (Clock, Year, Month, Day, Hour, Minute, Second, Sub_Second => Discard); diff --git a/main/gcc/ada/g-comlin.adb b/main/gcc/ada/g-comlin.adb index 20ee73ce650..440b5d12f3c 100644 --- a/main/gcc/ada/g-comlin.adb +++ b/main/gcc/ada/g-comlin.adb @@ -584,7 +584,6 @@ package body GNAT.Command_Line is Parser : Opt_Parser := Command_Line_Parser) return Character is Dummy : Boolean; - pragma Unreferenced (Dummy); begin <> diff --git a/main/gcc/ada/g-debpoo.adb b/main/gcc/ada/g-debpoo.adb index 5ee63d9896f..8d4372f6deb 100644 --- a/main/gcc/ada/g-debpoo.adb +++ b/main/gcc/ada/g-debpoo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Exceptions.Traceback; with GNAT.IO; use GNAT.IO; with System.Address_Image; with System.Memory; use System.Memory; with System.Soft_Links; use System.Soft_Links; -with System.Traceback_Entries; use System.Traceback_Entries; +with System.Traceback_Entries; with GNAT.HTable; with GNAT.Traceback; use GNAT.Traceback; @@ -45,11 +44,39 @@ with Ada.Unchecked_Conversion; package body GNAT.Debug_Pools is - Default_Alignment : constant := Standard'Maximum_Alignment; - -- Alignment used for the memory chunks returned by Allocate. Using this - -- value guarantees that this alignment will be compatible with all types - -- and at the same time makes it easy to find the location of the extra - -- header allocated for each chunk. + Storage_Alignment : constant := Standard'Maximum_Alignment; + -- Alignment enforced for all the memory chunks returned by Allocate, + -- maximized to make sure that it will be compatible with all types. + -- + -- The addresses returned by the underlying low-level allocator (be it + -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned + -- on some targets, so we manage the needed alignment padding ourselves + -- systematically. Use of a common value for every allocation allows + -- significant simplifications in the code, nevertheless, for improved + -- robustness and efficiency overall. + + -- We combine a few internal devices to offer the pool services: + -- + -- * A management header attached to each allocated memory block, located + -- right ahead of it, like so: + -- + -- Storage Address returned by the pool, + -- aligned on Storage_Alignment + -- v + -- +------+--------+--------------------- + -- | ~~~~ | HEADER | USER DATA ... | + -- +------+--------+--------------------- + -- <----> + -- alignment + -- padding + -- + -- The alignment padding is required + -- + -- * A validity bitmap, which holds a validity bit for blocks managed by + -- the pool. Enforcing Storage_Alignment on those blocks allows efficient + -- validity management. + -- + -- * A list of currently used blocks. Max_Ignored_Levels : constant Natural := 10; -- Maximum number of levels that will be ignored in backtraces. This is so @@ -79,8 +106,7 @@ package body GNAT.Debug_Pools is type Header is range 1 .. 1023; -- Number of elements in the hash-table - type Tracebacks_Array_Access - is access GNAT.Traceback.Tracebacks_Array; + type Tracebacks_Array_Access is access Tracebacks_Array; type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc); @@ -192,20 +218,26 @@ package body GNAT.Debug_Pools is (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address); Header_Offset : constant Storage_Count := - Default_Alignment * - ((Allocation_Header'Size / System.Storage_Unit - + Default_Alignment - 1) / Default_Alignment); - -- Offset of user data after allocation header - - Minimum_Allocation : constant Storage_Count := - Default_Alignment - 1 + Header_Offset; - -- Minimal allocation: size of allocation_header rounded up to next - -- multiple of default alignment + worst-case padding. + (Allocation_Header'Object_Size / System.Storage_Unit); + -- Offset, in bytes, from start of allocation Header to start of User + -- data. The start of user data is assumed to be aligned at least as much + -- as what the header type requires, so applying this offset yields a + -- suitably aligned address as well. + + Extra_Allocation : constant Storage_Count := + (Storage_Alignment - 1 + Header_Offset); + -- Amount we need to secure in addition to the user data for a given + -- allocation request: room for the allocation header plus worst-case + -- alignment padding. ----------------------- -- Local subprograms -- ----------------------- + function Align (Addr : Integer_Address) return Integer_Address; + pragma Inline (Align); + -- Return the next address aligned on Storage_Alignment from Addr. + function Find_Or_Create_Traceback (Pool : Debug_Pool; Kind : Traceback_Kind; @@ -273,8 +305,8 @@ package body GNAT.Debug_Pools is Code_Address_For_Deallocate_End : System.Address; Code_Address_For_Dereference_End : System.Address; -- Taking the address of the above procedures will not work on some - -- architectures (HPUX and VMS for instance). Thus we do the same thing - -- that is done in a-except.adb, and get the address of labels instead + -- architectures (HPUX for instance). Thus we do the same thing that + -- is done in a-except.adb, and get the address of labels instead. procedure Skip_Levels (Depth : Natural; @@ -289,6 +321,21 @@ package body GNAT.Debug_Pools is -- addresses internal to this package). Depth is the number of levels that -- the user is interested in. + package STBE renames System.Traceback_Entries; + + function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address + renames STBE.PC_For; + + ----------- + -- Align -- + ----------- + + function Align (Addr : Integer_Address) return Integer_Address is + Factor : constant Integer_Address := Storage_Alignment; + begin + return ((Addr + Factor - 1) / Factor) * Factor; + end Align; + --------------- -- Header_Of -- --------------- @@ -329,7 +376,7 @@ package body GNAT.Debug_Pools is ----------- function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is - use Ada.Exceptions.Traceback; + use type Tracebacks_Array; begin return K1.all = K2.all; end Equal; @@ -522,7 +569,7 @@ package body GNAT.Debug_Pools is -- that two chunk of allocated data are very far from each other. Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB - Validity_Divisor : constant := Default_Alignment * System.Storage_Unit; + Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit; Max_Validity_Byte_Index : constant := Memory_Chunk_Size / Validity_Divisor; @@ -575,12 +622,12 @@ package body GNAT.Debug_Pools is Int_Storage : constant Integer_Address := To_Integer (Storage); begin - -- The pool only returns addresses aligned on Default_Alignment so + -- The pool only returns addresses aligned on Storage_Alignment so -- anything off cannot be a valid block address and we can return -- early in this case. We actually have to since our data structures -- map validity bits for such aligned addresses only. - if Int_Storage mod Default_Alignment /= 0 then + if Int_Storage mod Storage_Alignment /= 0 then return False; end if; @@ -592,7 +639,7 @@ package body GNAT.Debug_Pools is Offset : constant Integer_Address := (Int_Storage - (Block_Number * Memory_Chunk_Size)) / - Default_Alignment; + Storage_Alignment; Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit); begin @@ -615,7 +662,7 @@ package body GNAT.Debug_Pools is Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); Offset : constant Integer_Address := (Int_Storage - (Block_Number * Memory_Chunk_Size)) / - Default_Alignment; + Storage_Alignment; Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit); @@ -656,11 +703,12 @@ package body GNAT.Debug_Pools is Size_In_Storage_Elements : Storage_Count; Alignment : Storage_Count) is + pragma Unreferenced (Alignment); - -- Ignored, we always force 'Default_Alignment + -- Ignored, we always force Storage_Alignment type Local_Storage_Array is new Storage_Array - (1 .. Size_In_Storage_Elements + Minimum_Allocation); + (1 .. Size_In_Storage_Elements + Extra_Allocation); type Ptr is access Local_Storage_Array; -- On some systems, we might want to physically protect pages against @@ -705,17 +753,33 @@ package body GNAT.Debug_Pools is P := new Local_Storage_Array; end; - Storage_Address := - To_Address - (Default_Alignment * - ((To_Integer (P.all'Address) + Default_Alignment - 1) - / Default_Alignment) - + Integer_Address (Header_Offset)); + -- Compute Storage_Address, aimed at receiving user data. We need room + -- for the allocation header just ahead of the user data space plus + -- alignment padding so Storage_Address is aligned on Storage_Alignment, + -- like so: + -- + -- Storage_Address, aligned + -- on Storage_Alignment + -- v + -- | ~~~~ | Header | User data ... | + -- ^........^ + -- Header_Offset + -- + -- Header_Offset is fixed so moving back and forth between user data + -- and allocation header is straightforward. The value is also such + -- that the header type alignment is honored when starting from + -- Default_alignment. + + -- For the purpose of computing Storage_Address, we just do as if the + -- header was located first, followed by the alignment padding: + + Storage_Address := To_Address + (Align (To_Integer (P.all'Address) + Integer_Address (Header_Offset))); -- Computation is done in Integer_Address, not Storage_Offset, because -- the range of Storage_Offset may not be large enough. pragma Assert ((Storage_Address - System.Null_Address) - mod Default_Alignment = 0); + mod Storage_Alignment = 0); pragma Assert (Storage_Address + Size_In_Storage_Elements <= P.all'Address + P'Length); @@ -726,7 +790,7 @@ package body GNAT.Debug_Pools is pragma Warnings (Off); -- Turn warning on alignment for convert call off. We know that in fact -- this conversion is safe since P itself is always aligned on - -- Default_Alignment. + -- Storage_Alignment. Header_Of (Storage_Address).all := (Allocation_Address => P.all'Address, @@ -950,7 +1014,7 @@ package body GNAT.Debug_Pools is (Output_File (Pool), "info: Freeing physical memory " & Storage_Count'Image - ((abs Header.Block_Size) + Minimum_Allocation) + ((abs Header.Block_Size) + Extra_Allocation) & " bytes at 0x" & Address_Image (Header.Allocation_Address)); end if; @@ -1167,7 +1231,7 @@ package body GNAT.Debug_Pools is & Storage_Count'Image (Size_In_Storage_Elements) & " bytes at 0x" & Address_Image (Storage_Address) & " (physically" - & Storage_Count'Image (Header.Block_Size + Minimum_Allocation) + & Storage_Count'Image (Header.Block_Size + Extra_Allocation) & " bytes at 0x" & Address_Image (Header.Allocation_Address) & "), at "); Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, diff --git a/main/gcc/ada/g-decstr.adb b/main/gcc/ada/g-decstr.adb index 255e78a2614..ab8d06c2b7f 100644 --- a/main/gcc/ada/g-decstr.adb +++ b/main/gcc/ada/g-decstr.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2007-2013, AdaCore -- +-- Copyright (C) 2007-2014, 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- -- @@ -323,7 +323,6 @@ package body GNAT.Decode_String is procedure Next_Wide_Character (Input : String; Ptr : in out Natural) is Discard : Wide_Character; - pragma Unreferenced (Discard); begin Decode_Wide_Character (Input, Ptr, Discard); end Next_Wide_Character; @@ -334,7 +333,6 @@ package body GNAT.Decode_String is procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural) is Discard : Wide_Wide_Character; - pragma Unreferenced (Discard); begin Decode_Wide_Wide_Character (Input, Ptr, Discard); end Next_Wide_Wide_Character; diff --git a/main/gcc/ada/g-dirope.adb b/main/gcc/ada/g-dirope.adb index bf579f57da4..3b745b1c0ae 100644 --- a/main/gcc/ada/g-dirope.adb +++ b/main/gcc/ada/g-dirope.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2012, AdaCore -- +-- Copyright (C) 1998-2014, 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- -- @@ -693,7 +693,7 @@ package body GNAT.Directory_Operations is end Read; ------------------------- - -- Read_Is_Thread_Sage -- + -- Read_Is_Thread_Safe -- ------------------------- function Read_Is_Thread_Safe return Boolean is diff --git a/main/gcc/ada/g-dirope.ads b/main/gcc/ada/g-dirope.ads index 51d449d0481..fe02d3fd136 100644 --- a/main/gcc/ada/g-dirope.ads +++ b/main/gcc/ada/g-dirope.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2010, AdaCore -- +-- Copyright (C) 1998-2014, 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- -- @@ -37,10 +37,6 @@ -- See also child package GNAT.Directory_Operations.Iteration --- Note: support on OpenVMS is limited to the support of Unix-style --- directory names (OpenVMS native directory format is not supported). --- Read individual entries for more specific notes on OpenVMS support. - with System; with Ada.Strings.Maps; @@ -54,8 +50,6 @@ package GNAT.Directory_Operations is -- '\' character. It can also include drive letters if the operating -- system provides for this. The final '/' or '\' in a Dir_Name_Str is -- optional when passed as a procedure or function in parameter. - -- On OpenVMS, only Unix style path names are supported, not VMS style, - -- but the directory and file names are not case sensitive. type Dir_Type is limited private; -- A value used to reference a directory. Conceptually this value includes @@ -117,7 +111,7 @@ package GNAT.Directory_Operations is -- returned. Note that the contents of Path is case-sensitive on -- systems that have case-sensitive file names (like Unix), and -- non-case-sensitive on systems where the file system is also non- - -- case-sensitive (such as Windows, and OpenVMS). + -- case-sensitive (such as Windows). function Base_Name (Path : Path_Name; @@ -133,8 +127,8 @@ package GNAT.Directory_Operations is -- 'Path' and 'Dir_Name (Path) & Dir_Separator & Base_Name (Path)' -- represent the same file. -- - -- The comparison of Suffix is case-insensitive on systems such as Windows - -- and VMS where the file search is case-insensitive (e.g. on such systems, + -- The comparison of Suffix is case-insensitive on systems like Windows + -- where the file search is case-insensitive (e.g. on such systems, -- Base_Name ("/Users/AdaCore/BB12.patch", ".Patch") returns "BB12"). -- -- Note that the index bounds of the result match the corresponding indexes @@ -165,12 +159,11 @@ package GNAT.Directory_Operations is -- -- The Style argument indicates the syntax to be used for path names: -- - -- UNIX - -- Use '/' as the directory separator. The default on Unix systems - -- and on OpenVMS. - -- -- DOS - -- Use '\' as the directory separator. The default on Windows. + -- Use '\' as the directory separator (default on Windows) + -- + -- UNIX + -- Use '/' as the directory separator (default on all other systems) -- -- System_Default -- Use the default style for the current system @@ -179,24 +172,24 @@ package GNAT.Directory_Operations is function Expand_Path (Path : Path_Name; Mode : Environment_Style := System_Default) return Path_Name; - -- Returns Path with environment variables (or logical names on OpenVMS) - -- replaced by the current environment variable value. For example, - -- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment - -- variable is set to /home/joe and Mode is UNIX. If an environment - -- variable does not exists the variable will be replaced by the empty - -- string. Two dollar or percent signs are replaced by a single - -- dollar/percent sign. Note that a variable must start with a letter. + -- Returns Path with environment variables replaced by the current + -- environment variable value. For example, $HOME/mydir will be replaced + -- by /home/joe/mydir if $HOME environment variable is set to /home/joe and + -- Mode is UNIX. If an environment variable does not exists the variable + -- will be replaced by the empty string. Two dollar or percent signs are + -- replaced by a single dollar/percent sign. Note that a variable must + -- start with a letter. -- -- The Mode argument indicates the recognized syntax for environment -- variables as follows: -- -- UNIX - -- Environment variables and OpenVMS logical names use $ as prefix and - -- can use curly brackets as in ${HOME}/mydir. If there is no closing - -- curly bracket for an opening one then no translation is done, so for - -- example ${VAR/toto is returned as ${VAR/toto. The use of {} brackets - -- is required if the environment variable name contains other than - -- alphanumeric characters. + -- Environment variables use $ as prefix and can use curly brackets + -- as in ${HOME}/mydir. If there is no closing curly bracket for an + -- opening one then no translation is done, so for example ${VAR/toto + -- is returned as ${VAR/toto. The use of {} brackets is required if + -- the environment variable name contains other than alphanumeric + -- characters. -- -- DOS -- Environment variables uses % as prefix and suffix (e.g. %HOME%/dir). @@ -207,8 +200,8 @@ package GNAT.Directory_Operations is -- Recognize both forms described above. -- -- System_Default - -- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows, - -- depending on the running environment. What about other OS's??? + -- Uses either DOS on Windows, and UNIX on all other systems, depending + -- on the running environment. --------------- -- Iterators -- diff --git a/main/gcc/ada/g-eacodu-vms.adb b/main/gcc/ada/g-eacodu-vms.adb deleted file mode 100644 index ceff6e98c09..00000000000 --- a/main/gcc/ada/g-eacodu-vms.adb +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version - -with System; -with System.Aux_DEC; -separate (GNAT.Exception_Actions) -procedure Core_Dump (Occurrence : Exception_Occurrence) is - - use System; - use System.Aux_DEC; - - pragma Unreferenced (Occurrence); - - SS_IMGDMP : constant := 1276; - - subtype Cond_Value_Type is Unsigned_Longword; - subtype Access_Mode_Type is - Unsigned_Word range 0 .. 3; - Access_Mode_Zero : constant Access_Mode_Type := 0; - - Status : Cond_Value_Type; - - procedure Setexv ( - Status : out Cond_Value_Type; - Vector : Unsigned_Longword := 0; - Addres : Address := Address_Zero; - Acmode : Access_Mode_Type := Access_Mode_Zero; - Prvhnd : Unsigned_Longword := 0); - pragma Import (External, Setexv); - pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV", - (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type, - Unsigned_Longword), - (Value, Value, Value, Value, Value)); - - procedure Lib_Signal (I : Integer); - pragma Import (C, Lib_Signal); - pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value)); -begin - Setexv (Status, 1, Address_Zero, 3); - Lib_Signal (SS_IMGDMP); -end Core_Dump; diff --git a/main/gcc/ada/g-enblsp-vms-alpha.adb b/main/gcc/ada/g-enblsp-vms-alpha.adb deleted file mode 100644 index f932a075b88..00000000000 --- a/main/gcc/ada/g-enblsp-vms-alpha.adb +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent non-blocking spawn function --- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package --- should not be directly with'ed by an application program. - --- This version is for Alpha/VMS - -separate (GNAT.Expect) -procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) -is - function Alloc_Vfork_Blocks return Integer; - pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); - - function Get_Vfork_Jmpbuf return System.Address; - pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); - - function Get_Current_Invo_Context - (Addr : System.Address) return Process_Id; - pragma Import (C, Get_Current_Invo_Context, - "LIB$GET_CURRENT_INVO_CONTEXT"); - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - -begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - Command_With_Path := Locate_Exec_On_Path (Command); - - if Command_With_Path = null then - raise Invalid_Process; - end if; - - -- Fork a new process (it is not possible to do this in a subprogram) - - Descriptor.Pid := - (if Alloc_Vfork_Blocks >= 0 - then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1); - - -- Are we now in the child - - if Descriptor.Pid = Null_Pid then - - -- Prepare an array of arguments to pass to C - - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (1) := Arg.all'Address; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (J + 2 - Args'First) := Arg.all'Address; - end loop; - - Arg_List (Arg_List'Last) := System.Null_Address; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - Arg_List'Address); - end if; - - Free (Command_With_Path); - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - raise Invalid_Process; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; -end Non_Blocking_Spawn; diff --git a/main/gcc/ada/g-enblsp-vms-ia64.adb b/main/gcc/ada/g-enblsp-vms-ia64.adb deleted file mode 100644 index fa024474731..00000000000 --- a/main/gcc/ada/g-enblsp-vms-ia64.adb +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent non-blocking spawn function --- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package --- should not be directly with'ed by an application program. - --- This version is for IA64/VMS - -separate (GNAT.Expect) -procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) -is - function Alloc_Vfork_Blocks return Integer; - pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); - - function Get_Vfork_Jmpbuf return System.Address; - pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); - - function Setjmp1 (Addr : System.Address) return Process_Id; - pragma Import (C, Setjmp1, "decc$setjmp1"); - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - -begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - Command_With_Path := Locate_Exec_On_Path (Command); - - if Command_With_Path = null then - raise Invalid_Process; - end if; - - -- Fork a new process (it is not possible to do this in a subprogram) - - Descriptor.Pid := - (if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1); - - -- Are we now in the child - - if Descriptor.Pid = Null_Pid then - - -- Prepare an array of arguments to pass to C - - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (1) := Arg.all'Address; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (J + 2 - Args'First) := Arg.all'Address; - end loop; - - Arg_List (Arg_List'Last) := System.Null_Address; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - Arg_List'Address); - end if; - - Free (Command_With_Path); - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - raise Invalid_Process; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; -end Non_Blocking_Spawn; diff --git a/main/gcc/ada/g-excact.ads b/main/gcc/ada/g-excact.ads index 6111bc7fd02..44f067ddbb7 100644 --- a/main/gcc/ada/g-excact.ads +++ b/main/gcc/ada/g-excact.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +111,8 @@ package GNAT.Exception_Actions is procedure Core_Dump (Occurrence : Exception_Occurrence); -- Dump memory (called a core dump in some systems) if supported by the - -- OS (most unix systems and VMS), and abort execution of the application. - -- Under Windows this procedure will not dump the memory, it will only - -- abort execution. + -- OS (most unix systems), and abort execution of the application. Under + -- Windows this procedure will not dump the memory, it will only abort + -- execution. end GNAT.Exception_Actions; diff --git a/main/gcc/ada/i-cpp.adb b/main/gcc/ada/g-exctra.adb similarity index 85% rename from main/gcc/ada/i-cpp.adb rename to main/gcc/ada/g-exctra.adb index f7a48608877..8844fcf09e9 100644 --- a/main/gcc/ada/i-cpp.adb +++ b/main/gcc/ada/g-exctra.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- I N T E R F A C E S . C P P -- +-- G N A T . E X C E P T I O N _ T R A C E S -- -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2014, 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- -- @@ -29,7 +29,8 @@ -- -- ------------------------------------------------------------------------------ --- Dummy body to deal with bootstrap issues (there used to be a real body) +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -package body Interfaces.CPP is -end Interfaces.CPP; +pragma No_Body; diff --git a/main/gcc/ada/gnat.ads b/main/gcc/ada/g-exctra.ads similarity index 81% copy from main/gcc/ada/gnat.ads copy to main/gcc/ada/g-exctra.ads index cfdfdc837eb..aa264ba12a0 100644 --- a/main/gcc/ada/gnat.ads +++ b/main/gcc/ada/g-exctra.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T -- +-- G N A T . E X C E P T I O N _ T R A C E S -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -29,9 +29,11 @@ -- -- ------------------------------------------------------------------------------ --- This is the parent package for a library of useful units provided with GNAT +-- This package provides an interface allowing to control *automatic* output +-- to standard error upon exception occurrences (as opposed to explicit +-- generation of traceback information using System.Traceback). -package GNAT is - pragma Pure; +-- See file s-exctra.ads for full documentation of the interface -end GNAT; +with System.Exception_Traces; +package GNAT.Exception_Traces renames System.Exception_Traces; diff --git a/main/gcc/ada/g-expect-vms.adb b/main/gcc/ada/g-expect-vms.adb deleted file mode 100644 index cbffb574136..00000000000 --- a/main/gcc/ada/g-expect-vms.adb +++ /dev/null @@ -1,1307 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2014, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version - --- Note: there is far too much code duplication wrt g-expect.adb (the --- standard version). This should be factored out ??? - -with System; use System; -with Ada.Calendar; use Ada.Calendar; - -with GNAT.IO; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Regpat; use GNAT.Regpat; - -with Ada.Unchecked_Deallocation; - -package body GNAT.Expect is - - type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; - - Save_Input : File_Descriptor; - Save_Output : File_Descriptor; - Save_Error : File_Descriptor; - - Expect_Process_Died : constant Expect_Match := -100; - Expect_Internal_Error : constant Expect_Match := -101; - -- Additional possible outputs of Expect_Internal. These are not visible in - -- the spec because the user will never see them. - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean); - -- Internal function used to read from the process Descriptor. - -- - -- Several outputs are possible: - -- Result=Expect_Timeout, if no output was available before the timeout - -- expired. - -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters - -- had to be discarded from the internal buffer of Descriptor. - -- Result=Express_Process_Died if one of the processes was terminated. - -- That process's Input_Fd is set to Invalid_FD - -- Result=Express_Internal_Error - -- Result=, indicates how many characters were added to the - -- internal buffer. These characters are from indexes - -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index - -- Process_Died is raised if the process is no longer valid. - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class); - -- Reinitialize the internal buffer. - -- The buffer is deleted up to the end of the last match. - - procedure Free is new Ada.Unchecked_Deallocation - (Pattern_Matcher, Pattern_Matcher_Access); - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type); - -- Call all the filters that have the appropriate type. - -- This function does nothing if the filters are locked - - ------------------------------ - -- Target dependent section -- - ------------------------------ - - function Dup (Fd : File_Descriptor) return File_Descriptor; - pragma Import (C, Dup, "decc$dup"); - - procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); - pragma Import (C, Dup2, "decc$dup2"); - - procedure Kill (Pid : Process_Id; Sig_Num : Integer); - pragma Import (C, Kill, "decc$kill"); - - function Create_Pipe (Pipe : not null access Pipe_Type) return Integer; - pragma Import (C, Create_Pipe, "__gnat_pipe"); - - function Poll - (Fds : System.Address; - Num_Fds : Integer; - Timeout : Integer; - Is_Set : System.Address) return Integer; - pragma Import (C, Poll, "__gnat_expect_poll"); - -- Check whether there is any data waiting on the file descriptor - -- Out_fd, and wait if there is none, at most Timeout milliseconds - -- Returns -1 in case of error, 0 if the timeout expired before - -- data became available. - -- - -- Out_Is_Set is set to 1 if data was available, 0 otherwise. - - function Waitpid (Pid : Process_Id) return Integer; - pragma Import (C, Waitpid, "__gnat_waitpid"); - -- Wait for a specific process id, and return its exit code - - --------- - -- "+" -- - --------- - - function "+" (S : String) return GNAT.OS_Lib.String_Access is - begin - return new String'(S); - end "+"; - - --------- - -- "+" -- - --------- - - function "+" - (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access - is - begin - return new GNAT.Regpat.Pattern_Matcher'(P); - end "+"; - - ---------------- - -- Add_Filter -- - ---------------- - - procedure Add_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function; - Filter_On : Filter_Type := Output; - User_Data : System.Address := System.Null_Address; - After : Boolean := False) - is - Current : Filter_List := Descriptor.Filters; - - begin - if After then - while Current /= null and then Current.Next /= null loop - Current := Current.Next; - end loop; - - if Current = null then - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - else - Current.Next := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - end if; - - else - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => Descriptor.Filters); - end if; - end Add_Filter; - - ------------------ - -- Call_Filters -- - ------------------ - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type) - is - Current_Filter : Filter_List; - - begin - if Pid.Filters_Lock = 0 then - Current_Filter := Pid.Filters; - - while Current_Filter /= null loop - if Current_Filter.Filter_On = Filter_On then - Current_Filter.Filter - (Pid, Str, Current_Filter.User_Data); - end if; - - Current_Filter := Current_Filter.Next; - end loop; - end if; - end Call_Filters; - - ----------- - -- Close -- - ----------- - - procedure Close - (Descriptor : in out Process_Descriptor; - Status : out Integer) - is - begin - if Descriptor.Input_Fd /= Invalid_FD then - Close (Descriptor.Input_Fd); - end if; - - if Descriptor.Error_Fd /= Descriptor.Output_Fd then - Close (Descriptor.Error_Fd); - end if; - - Close (Descriptor.Output_Fd); - - -- ??? Should have timeouts for different signals - - if Descriptor.Pid > 0 then -- see comment in Send_Signal - Kill (Descriptor.Pid, Sig_Num => 9); - end if; - - GNAT.OS_Lib.Free (Descriptor.Buffer); - Descriptor.Buffer_Size := 0; - - -- Check process id (see comment in Send_Signal) - - if Descriptor.Pid > 0 then - Status := Waitpid (Descriptor.Pid); - else - raise Invalid_Process; - end if; - end Close; - - procedure Close (Descriptor : in out Process_Descriptor) is - Status : Integer; - begin - Close (Descriptor, Status); - end Close; - - ------------ - -- Expect -- - ------------ - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - begin - if Regexp = "" then - Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); - else - Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - begin - pragma Assert (Matched'First = 0); - if Regexp = "" then - Expect - (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); - else - Expect - (Descriptor, Result, Compile (Regexp), Matched, Timeout, - Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; - Timeout_Tmp : Integer := Timeout; - - begin - pragma Assert (Matched'First = 0); - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - - -- Else try to read new input - - Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - - case N is - when Expect_Internal_Error | Expect_Process_Died => - raise Process_Died; - - when Expect_Timeout | Expect_Full_Buffer => - Result := N; - return; - - when others => - null; -- See below - end case; - - -- Calculate the timeout for the next turn - - -- Note that Timeout is, from the caller's perspective, the maximum - -- time until a match, not the maximum time until some output is - -- read, and thus cannot be reused as is for Expect_Internal. - - if Timeout /= -1 then - Timeout_Tmp := Integer (Try_Until - Clock) * 1000; - - if Timeout_Tmp < 0 then - Result := Expect_Timeout; - exit; - end if; - end if; - end loop; - - -- Even if we had the general timeout above, we have to test that the - -- last test we read from the external process didn't match. - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - begin - pragma Assert (Matched'First = 0); - - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - if Descriptor.Buffer /= null then - for J in Regexps'Range loop - Match - (Regexps (J).all, - Descriptor.Buffer (1 .. Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end loop; - end if; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - case N is - when Expect_Internal_Error | Expect_Process_Died => - raise Process_Died; - - when Expect_Timeout | Expect_Full_Buffer => - Result := N; - return; - - when others => - null; -- Continue - end case; - end loop; - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Descriptors'Range loop - Descriptors (J) := Regexps (J).Descriptor; - - if Descriptors (J) /= null then - Reinitialize_Buffer (Regexps (J).Descriptor.all); - end if; - end loop; - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - for J in Regexps'Range loop - if Regexps (J).Regexp /= null - and then Regexps (J).Descriptor /= null - then - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end if; - end loop; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - case N is - when Expect_Internal_Error | Expect_Process_Died => - raise Process_Died; - - when Expect_Timeout | Expect_Full_Buffer => - Result := N; - return; - - when others => - null; -- Continue - end case; - end loop; - end Expect; - - --------------------- - -- Expect_Internal -- - --------------------- - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean) - is - Num_Descriptors : Integer; - Buffer_Size : Integer := 0; - - N : Integer; - - type File_Descriptor_Array is - array (0 .. Descriptors'Length - 1) of File_Descriptor; - Fds : aliased File_Descriptor_Array; - Fds_Count : Natural := 0; - - Fds_To_Descriptor : array (Fds'Range) of Integer; - -- Maps file descriptor entries from Fds to entries in Descriptors. - -- They do not have the same index when entries in Descriptors are null. - - type Integer_Array is array (Fds'Range) of Integer; - Is_Set : aliased Integer_Array; - - begin - for J in Descriptors'Range loop - if Descriptors (J) /= null then - Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; - Fds_To_Descriptor (Fds'First + Fds_Count) := J; - Fds_Count := Fds_Count + 1; - - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); - end if; - end if; - end loop; - - declare - Buffer : aliased String (1 .. Buffer_Size); - -- Buffer used for input. This is allocated only once, not for - -- every iteration of the loop - - D : Integer; - -- Index in Descriptors - - begin - -- Loop until we match or we have a timeout - - loop - Num_Descriptors := - Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); - - case Num_Descriptors is - - -- Error? - - when -1 => - Result := Expect_Internal_Error; - return; - - -- Timeout? - - when 0 => - Result := Expect_Timeout; - return; - - -- Some input - - when others => - for F in Fds'Range loop - if Is_Set (F) = 1 then - D := Fds_To_Descriptor (F); - - Buffer_Size := Descriptors (D).Buffer_Size; - - if Buffer_Size = 0 then - Buffer_Size := 4096; - end if; - - N := Read (Descriptors (D).Output_Fd, Buffer'Address, - Buffer_Size); - - -- Error or End of file - - if N <= 0 then - -- ??? Note that ddd tries again up to three times - -- in that case. See LiterateA.C:174 - - Descriptors (D).Input_Fd := Invalid_FD; - Result := Expect_Process_Died; - return; - - else - -- If there is no limit to the buffer size - - if Descriptors (D).Buffer_Size = 0 then - - declare - Tmp : String_Access := Descriptors (D).Buffer; - - begin - if Tmp /= null then - Descriptors (D).Buffer := - new String (1 .. Tmp'Length + N); - Descriptors (D).Buffer (1 .. Tmp'Length) := - Tmp.all; - Descriptors (D).Buffer - (Tmp'Length + 1 .. Tmp'Length + N) := - Buffer (1 .. N); - Free (Tmp); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer'Last; - - else - Descriptors (D).Buffer := - new String (1 .. N); - Descriptors (D).Buffer.all := - Buffer (1 .. N); - Descriptors (D).Buffer_Index := N; - end if; - end; - - else - -- Add what we read to the buffer - - if Descriptors (D).Buffer_Index + N > - Descriptors (D).Buffer_Size - then - -- If the user wants to know when we have - -- read more than the buffer can contain. - - if Full_Buffer then - Result := Expect_Full_Buffer; - return; - end if; - - -- Keep as much as possible from the buffer, - -- and forget old characters. - - Descriptors (D).Buffer - (1 .. Descriptors (D).Buffer_Size - N) := - Descriptors (D).Buffer - (N - Descriptors (D).Buffer_Size + - Descriptors (D).Buffer_Index + 1 .. - Descriptors (D).Buffer_Index); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer_Size - N; - end if; - - -- Keep what we read in the buffer - - Descriptors (D).Buffer - (Descriptors (D).Buffer_Index + 1 .. - Descriptors (D).Buffer_Index + N) := - Buffer (1 .. N); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer_Index + N; - end if; - - -- Call each of the output filter with what we - -- read. - - Call_Filters - (Descriptors (D).all, Buffer (1 .. N), Output); - - Result := Expect_Match (D); - return; - end if; - end if; - end loop; - end case; - end loop; - end; - end Expect_Internal; - - ---------------- - -- Expect_Out -- - ---------------- - - function Expect_Out (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); - end Expect_Out; - - ---------------------- - -- Expect_Out_Match -- - ---------------------- - - function Expect_Out_Match (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer - (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); - end Expect_Out_Match; - - ------------------------ - -- First_Dead_Process -- - ------------------------ - - function First_Dead_Process - (Regexp : Multiprocess_Regexp_Array) return Natural - is - begin - for R in Regexp'Range loop - if Regexp (R).Descriptor /= null - and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD - then - return R; - end if; - end loop; - - return 0; - end First_Dead_Process; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Descriptor : in out Process_Descriptor; - Timeout : Integer := 0) - is - Buffer_Size : constant Integer := 8192; - Num_Descriptors : Integer; - N : Integer; - Is_Set : aliased Integer; - Buffer : aliased String (1 .. Buffer_Size); - - begin - -- Empty the current buffer - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - Reinitialize_Buffer (Descriptor); - - -- Read everything from the process to flush its output - - loop - Num_Descriptors := - Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); - - case Num_Descriptors is - - -- Error ? - - when -1 => - raise Process_Died; - - -- Timeout => End of flush - - when 0 => - return; - - -- Some input - - when others => - if Is_Set = 1 then - N := Read (Descriptor.Output_Fd, Buffer'Address, - Buffer_Size); - - if N = -1 then - raise Process_Died; - elsif N = 0 then - return; - end if; - end if; - end case; - end loop; - end Flush; - - ---------- - -- Free -- - ---------- - - procedure Free (Regexp : in out Multiprocess_Regexp) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Process_Descriptor'Class, Process_Descriptor_Access); - begin - Unchecked_Free (Regexp.Descriptor); - Free (Regexp.Regexp); - end Free; - - ------------------------ - -- Get_Command_Output -- - ------------------------ - - function Get_Command_Output - (Command : String; - Arguments : GNAT.OS_Lib.Argument_List; - Input : String; - Status : not null access Integer; - Err_To_Out : Boolean := False) return String - is - use GNAT.Expect; - - Process : Process_Descriptor; - - Output : String_Access := new String (1 .. 1024); - -- Buffer used to accumulate standard output from the launched - -- command, expanded as necessary during execution. - - Last : Integer := 0; - -- Index of the last used character within Output - - begin - Non_Blocking_Spawn - (Process, Command, Arguments, Err_To_Out => Err_To_Out); - - if Input'Length > 0 then - Send (Process, Input); - end if; - - GNAT.OS_Lib.Close (Get_Input_Fd (Process)); - - declare - Result : Expect_Match; - - begin - -- This loop runs until the call to Expect raises Process_Died - - loop - Expect (Process, Result, ".+"); - - declare - NOutput : String_Access; - S : constant String := Expect_Out (Process); - pragma Assert (S'Length > 0); - - begin - -- Expand buffer if we need more space - - if Last + S'Length > Output'Last then - NOutput := new String (1 .. 2 * Output'Last); - NOutput (Output'Range) := Output.all; - Free (Output); - - -- Here if current buffer size is OK - - else - NOutput := Output; - end if; - - NOutput (Last + 1 .. Last + S'Length) := S; - Last := Last + S'Length; - Output := NOutput; - end; - end loop; - - exception - when Process_Died => - Close (Process, Status.all); - end; - - if Last = 0 then - return ""; - end if; - - declare - S : constant String := Output (1 .. Last); - begin - Free (Output); - return S; - end; - end Get_Command_Output; - - ------------------ - -- Get_Error_Fd -- - ------------------ - - function Get_Error_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Error_Fd; - end Get_Error_Fd; - - ------------------ - -- Get_Input_Fd -- - ------------------ - - function Get_Input_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Input_Fd; - end Get_Input_Fd; - - ------------------- - -- Get_Output_Fd -- - ------------------- - - function Get_Output_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Output_Fd; - end Get_Output_Fd; - - ------------- - -- Get_Pid -- - ------------- - - function Get_Pid - (Descriptor : Process_Descriptor) return Process_Id - is - begin - return Descriptor.Pid; - end Get_Pid; - - ----------------- - -- Has_Process -- - ----------------- - - function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is - begin - return Regexp /= (Regexp'Range => (null, null)); - end Has_Process; - - --------------- - -- Interrupt -- - --------------- - - procedure Interrupt (Descriptor : in out Process_Descriptor) is - SIGINT : constant := 2; - begin - Send_Signal (Descriptor, SIGINT); - end Interrupt; - - ------------------ - -- Lock_Filters -- - ------------------ - - procedure Lock_Filters (Descriptor : in out Process_Descriptor) is - begin - Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; - end Lock_Filters; - - ------------------------ - -- Non_Blocking_Spawn -- - ------------------------ - - procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) - is separate; - - ------------------------- - -- Reinitialize_Buffer -- - ------------------------- - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class) - is - begin - if Descriptor.Buffer_Size = 0 then - declare - Tmp : String_Access := Descriptor.Buffer; - - begin - Descriptor.Buffer := - new String - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); - - if Tmp /= null then - Descriptor.Buffer.all := Tmp - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - Free (Tmp); - end if; - end; - - Descriptor.Buffer_Index := Descriptor.Buffer'Last; - - else - Descriptor.Buffer - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := - Descriptor.Buffer - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - - if Descriptor.Buffer_Index > Descriptor.Last_Match_End then - Descriptor.Buffer_Index := - Descriptor.Buffer_Index - Descriptor.Last_Match_End; - else - Descriptor.Buffer_Index := 0; - end if; - end if; - - Descriptor.Last_Match_Start := 0; - Descriptor.Last_Match_End := 0; - end Reinitialize_Buffer; - - ------------------- - -- Remove_Filter -- - ------------------- - - procedure Remove_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function) - is - Previous : Filter_List := null; - Current : Filter_List := Descriptor.Filters; - - begin - while Current /= null loop - if Current.Filter = Filter then - if Previous = null then - Descriptor.Filters := Current.Next; - else - Previous.Next := Current.Next; - end if; - end if; - - Previous := Current; - Current := Current.Next; - end loop; - end Remove_Filter; - - ---------- - -- Send -- - ---------- - - procedure Send - (Descriptor : in out Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False) - is - Full_Str : constant String := Str & ASCII.LF; - Last : Natural; - Result : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - Discard : Natural; - pragma Unreferenced (Discard); - - begin - if Empty_Buffer then - - -- Force a read on the process if there is anything waiting - - Expect_Internal (Descriptors, Result, - Timeout => 0, Full_Buffer => False); - - if Result = Expect_Internal_Error - or else Result = Expect_Process_Died - then - raise Process_Died; - end if; - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - - -- Empty the buffer - - Reinitialize_Buffer (Descriptor); - end if; - - Last := (if Add_LF then Full_Str'Last else Full_Str'Last - 1); - - Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); - - Discard := - Write (Descriptor.Input_Fd, - Full_Str'Address, - Last - Full_Str'First + 1); - -- Shouldn't we at least have a pragma Assert on the result ??? - end Send; - - ----------------- - -- Send_Signal -- - ----------------- - - procedure Send_Signal - (Descriptor : Process_Descriptor; - Signal : Integer) - is - begin - -- A nonpositive process id passed to kill has special meanings. For - -- example, -1 means kill all processes in sight, including self, in - -- POSIX and Windows (and something slightly different in Linux). See - -- man pages for details. In any case, we don't want to do that. Note - -- that Descriptor.Pid will be -1 if the process was not successfully - -- started; we don't want to kill ourself in that case. - - if Descriptor.Pid > 0 then - Kill (Descriptor.Pid, Signal); - -- ??? Need to check process status here - else - raise Invalid_Process; - end if; - end Send_Signal; - - --------------------------------- - -- Set_Up_Child_Communications -- - --------------------------------- - - procedure Set_Up_Child_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : String; - Args : System.Address) - is - pragma Warnings (Off, Pid); - pragma Warnings (Off, Pipe1); - pragma Warnings (Off, Pipe2); - pragma Warnings (Off, Pipe3); - - begin - -- Since the code between fork and exec on VMS executes - -- in the context of the parent process, we need to - -- perform the following actions: - -- - save stdin, stdout, stderr - -- - replace them by our pipes - -- - create the child with process handle inheritance - -- - revert to the previous stdin, stdout and stderr. - - Save_Input := Dup (GNAT.OS_Lib.Standin); - Save_Output := Dup (GNAT.OS_Lib.Standout); - Save_Error := Dup (GNAT.OS_Lib.Standerr); - - -- Since we are still called from the parent process, there is no way - -- currently we can cleanly close the unneeded ends of the pipes, but - -- this doesn't really matter. - - -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input - - Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); - Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); - Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); - - Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); - end Set_Up_Child_Communications; - - --------------------------- - -- Set_Up_Communications -- - --------------------------- - - procedure Set_Up_Communications - (Pid : in out Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : not null access Pipe_Type; - Pipe2 : not null access Pipe_Type; - Pipe3 : not null access Pipe_Type) - is - begin - -- Create the pipes - - if Create_Pipe (Pipe1) /= 0 then - return; - end if; - - if Create_Pipe (Pipe2) /= 0 then - return; - end if; - - Pid.Input_Fd := Pipe1.Output; - Pid.Output_Fd := Pipe2.Input; - - if Err_To_Out then - Pipe3.all := Pipe2.all; - else - if Create_Pipe (Pipe3) /= 0 then - return; - end if; - end if; - - Pid.Error_Fd := Pipe3.Input; - end Set_Up_Communications; - - ---------------------------------- - -- Set_Up_Parent_Communications -- - ---------------------------------- - - procedure Set_Up_Parent_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type) - is - pragma Warnings (Off, Pid); - pragma Warnings (Off, Pipe1); - pragma Warnings (Off, Pipe2); - pragma Warnings (Off, Pipe3); - - begin - - Dup2 (Save_Input, GNAT.OS_Lib.Standin); - Dup2 (Save_Output, GNAT.OS_Lib.Standout); - Dup2 (Save_Error, GNAT.OS_Lib.Standerr); - - Close (Save_Input); - Close (Save_Output); - Close (Save_Error); - - Close (Pipe1.Input); - Close (Pipe2.Output); - Close (Pipe3.Output); - end Set_Up_Parent_Communications; - - ------------------ - -- Trace_Filter -- - ------------------ - - procedure Trace_Filter - (Descriptor : Process_Descriptor'Class; - Str : String; - User_Data : System.Address := System.Null_Address) - is - pragma Warnings (Off, Descriptor); - pragma Warnings (Off, User_Data); - begin - GNAT.IO.Put (Str); - end Trace_Filter; - - -------------------- - -- Unlock_Filters -- - -------------------- - - procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is - begin - if Descriptor.Filters_Lock > 0 then - Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; - end if; - end Unlock_Filters; - -end GNAT.Expect; diff --git a/main/gcc/ada/g-expect.adb b/main/gcc/ada/g-expect.adb index 94f69642af4..94f80e92263 100644 --- a/main/gcc/ada/g-expect.adb +++ b/main/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2012, AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -104,17 +104,22 @@ package body GNAT.Expect is pragma Import (C, Create_Pipe, "__gnat_pipe"); function Poll - (Fds : System.Address; - Num_Fds : Integer; - Timeout : Integer; - Is_Set : System.Address) return Integer; + (Fds : System.Address; + Num_Fds : Integer; + Timeout : Integer; + Dead_Process : access Integer; + Is_Set : System.Address) return Integer; pragma Import (C, Poll, "__gnat_expect_poll"); - -- Check whether there is any data waiting on the file descriptor - -- Out_fd, and wait if there is none, at most Timeout milliseconds + -- Check whether there is any data waiting on the file descriptors + -- Fds, and wait if there is none, at most Timeout milliseconds -- Returns -1 in case of error, 0 if the timeout expired before -- data became available. -- - -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + -- Is_Set is an array of the same size as FDs and elements are set to 1 if + -- data is available for the corresponding File Descriptor, 0 otherwise. + -- + -- If a process dies, then Dead_Process is set to the index of the + -- corresponding file descriptor. function Waitpid (Pid : Process_Id) return Integer; pragma Import (C, Waitpid, "__gnat_waitpid"); @@ -632,7 +637,7 @@ package body GNAT.Expect is -- Buffer used for input. This is allocated only once, not for -- every iteration of the loop - D : Integer; + D : aliased Integer; -- Index in Descriptors begin @@ -640,7 +645,7 @@ package body GNAT.Expect is loop Num_Descriptors := - Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); + Poll (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address); case Num_Descriptors is @@ -648,6 +653,12 @@ package body GNAT.Expect is when -1 => Result := Expect_Internal_Error; + + if D /= 0 then + Close (Descriptors (D).Input_Fd); + Descriptors (D).Input_Fd := Invalid_FD; + end if; + return; -- Timeout? @@ -813,7 +824,7 @@ package body GNAT.Expect is is Buffer_Size : constant Integer := 8192; Num_Descriptors : Integer; - N : Integer; + N : aliased Integer; Is_Set : aliased Integer; Buffer : aliased String (1 .. Buffer_Size); @@ -827,7 +838,11 @@ package body GNAT.Expect is loop Num_Descriptors := - Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); + Poll (Descriptor.Output_Fd'Address, + 1, + Timeout, + N'Access, + Is_Set'Address); case Num_Descriptors is diff --git a/main/gcc/ada/g-expect.ads b/main/gcc/ada/g-expect.ads index 22b84ca00f3..0dc634110ee 100644 --- a/main/gcc/ada/g-expect.ads +++ b/main/gcc/ada/g-expect.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2010, AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- Currently this package is implemented on all native GNAT ports except --- for VMS. It is not yet implemented for any of the cross-ports (e.g. it --- is not available for VxWorks or LynxOS). +-- Currently this package is implemented on all native GNAT ports. It is not +-- yet implemented for any of the cross-ports (e.g. it is not available for +-- VxWorks or LynxOS). -- ----------- -- -- Usage -- @@ -178,7 +178,7 @@ package GNAT.Expect is -- till Expect matches), but this is slower. -- -- If Err_To_Out is True, then the standard error of the spawned process is - -- connected to the standard output. This is the only way to get the Except + -- connected to the standard output. This is the only way to get the Expect -- subprograms to also match on output on standard error. -- -- Invalid_Process is raised if the process could not be spawned. diff --git a/main/gcc/ada/g-exptty.adb b/main/gcc/ada/g-exptty.adb index 7ec04727d07..8b7fd6ee268 100644 --- a/main/gcc/ada/g-exptty.adb +++ b/main/gcc/ada/g-exptty.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2014, 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,7 +50,7 @@ package body GNAT.Expect.TTY is pragma Import (C, Terminate_Process, "__gnat_terminate_process"); function Waitpid (Process : System.Address) return Integer; - pragma Import (C, Waitpid, "__gnat_waitpid"); + pragma Import (C, Waitpid, "__gnat_tty_waitpid"); -- Wait for a specific process id, and return its exit code procedure Free_Process (Process : System.Address); @@ -66,6 +66,18 @@ package body GNAT.Expect.TTY is Status := -1; else + -- Send a Ctrl-C to the process first. This way, if the launched + -- process is a "sh" or "cmd", the child processes will get + -- terminated as well. Otherwise, terminating the main process + -- brutally will leave the children running. + + -- Note: special characters are sent to the terminal to generate the + -- signal, so this needs to be done while the file descriptors are + -- still open (it used to be after the closes and that was wrong). + + Interrupt (Descriptor); + delay (0.05); + if Descriptor.Input_Fd /= Invalid_FD then Close (Descriptor.Input_Fd); end if; @@ -80,14 +92,6 @@ package body GNAT.Expect.TTY is Close (Descriptor.Output_Fd); end if; - -- Send a Ctrl-C to the process first. This way, if the - -- launched process is a "sh" or "cmd", the child processes - -- will get terminated as well. Otherwise, terminating the - -- main process brutally will leave the children running. - - Interrupt (Descriptor); - delay 0.05; - Terminate_Process (Descriptor.Process); Status := Waitpid (Descriptor.Process); diff --git a/main/gcc/ada/g-forstr.adb b/main/gcc/ada/g-forstr.adb new file mode 100644 index 00000000000..a6ebc919303 --- /dev/null +++ b/main/gcc/ada/g-forstr.adb @@ -0,0 +1,981 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . F O R M A T T E D _ S T R I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; +with Ada.Float_Text_IO; +with Ada.Integer_Text_IO; +with Ada.Long_Float_Text_IO; +with Ada.Long_Integer_Text_IO; +with Ada.Strings.Fixed; +with Ada.Unchecked_Deallocation; + +with System.Address_Image; + +package body GNAT.Formatted_String is + + type F_Kind is (Decimal_Int, -- %d %i + Unsigned_Decimal_Int, -- %u + Unsigned_Octal, -- %o + Unsigned_Hexadecimal_Int, -- %x + Unsigned_Hexadecimal_Int_Up, -- %X + Decimal_Float, -- %f %F + Decimal_Scientific_Float, -- %e + Decimal_Scientific_Float_Up, -- %E + Shortest_Decimal_Float, -- %g + Shortest_Decimal_Float_Up, -- %G + Char, -- %c + Str, -- %s + Pointer -- %p + ); + + type Sign_Kind is (Neg, Zero, Pos); + + subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float; + + type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg; + + type F_Base is (None, C_Style, Ada_Style) with Default_Value => None; + + Unset : constant Integer := -1; + + type F_Data is record + Kind : F_Kind; + Width : Natural := 0; + Precision : Integer := Unset; + Left_Justify : Boolean := False; + Sign : F_Sign; + Base : F_Base; + Zero_Pad : Boolean := False; + Value_Needed : Natural range 0 .. 2 := 0; + end record; + + procedure Next_Format + (Format : Formatted_String; + F_Spec : out F_Data; + Start : out Positive); + -- Parse the next format specifier, a format specifier has the following + -- syntax: %[flags][width][.precision][length]specifier + + function Get_Formatted + (F_Spec : F_Data; + Value : String; + Len : Positive) return String; + -- Returns Value formatted given the information in F_Spec + + procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return; + -- Raise the Format_Error exception which information about the context + + generic + type Flt is private; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function P_Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- Generic routine which handles all floating point numbers + + generic + type Int is private; + + with function To_Integer (Item : Int) return Integer; + + with function Sign (Item : Int) return Sign_Kind; + + with procedure Put + (To : out String; + Item : Int; + Base : Text_IO.Number_Base); + function P_Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String; + -- Generic routine which handles all the integer numbers + + --------- + -- "+" -- + --------- + + function "+" (Format : String) return Formatted_String is + begin + return Formatted_String' + (Finalization.Controlled with + D => new Data'(Format'Length, 1, Format, 1, + Null_Unbounded_String, 0, 0, (0, 0))); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Format : Formatted_String) return String is + F : String renames Format.D.Format; + J : Natural renames Format.D.Index; + R : Unbounded_String := Format.D.Result; + + begin + -- Make sure we get the remaining character up to the next unhandled + -- format specifier. + + while (J <= F'Length and then F (J) /= '%') + or else (J < F'Length - 1 and then F (J + 1) = '%') + loop + Append (R, F (J)); + + -- If we have two consecutive %, skip the second one + + if F (J) = '%' and then J < F'Length - 1 and then F (J + 1) = '%' then + J := J + 1; + end if; + + J := J + 1; + end loop; + + return To_String (R); + end "-"; + + --------- + -- "&" -- + --------- + + function "&" + (Format : Formatted_String; + Var : Character) return Formatted_String + is + F : F_Data; + Start : Positive; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + case F.Kind is + when Char => + Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1)); + when others => + Raise_Wrong_Format (Format); + end case; + + return Format; + end "&"; + + function "&" + (Format : Formatted_String; + Var : String) return Formatted_String + is + F : F_Data; + Start : Positive; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + case F.Kind is + when Str => + declare + S : constant String := Get_Formatted (F, Var, Var'Length); + begin + if F.Precision = Unset then + Append (Format.D.Result, S); + else + Append + (Format.D.Result, + S (S'First .. S'First + F.Precision - 1)); + end if; + end; + + when others => + Raise_Wrong_Format (Format); + end case; + + return Format; + end "&"; + + function "&" + (Format : Formatted_String; + Var : Boolean) return Formatted_String is + begin + return Format & Boolean'Image (Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Float) return Formatted_String + is + function Float_Format is new Flt_Format (Float, Float_Text_IO.Put); + begin + return Float_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Long_Float) return Formatted_String + is + function Float_Format is + new Flt_Format (Long_Float, Long_Float_Text_IO.Put); + begin + return Float_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Duration) return Formatted_String + is + package Duration_Text_IO is new Text_IO.Fixed_IO (Duration); + function Duration_Format is + new P_Flt_Format (Duration, Duration_Text_IO.Put); + begin + return Duration_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Integer) return Formatted_String + is + function Integer_Format is + new Int_Format (Integer, Integer_Text_IO.Put); + begin + return Integer_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Long_Integer) return Formatted_String + is + function Integer_Format is + new Int_Format (Long_Integer, Long_Integer_Text_IO.Put); + begin + return Integer_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : System.Address) return Formatted_String + is + A_Img : constant String := System.Address_Image (Var); + F : F_Data; + Start : Positive; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + case F.Kind is + when Pointer => + Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length)); + when others => + Raise_Wrong_Format (Format); + end case; + + return Format; + end "&"; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (F : in out Formatted_String) is + begin + F.D.Ref_Count := F.D.Ref_Count + 1; + end Adjust; + + -------------------- + -- Decimal_Format -- + -------------------- + + function Decimal_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + function Flt_Format is new P_Flt_Format (Flt, Put); + begin + return Flt_Format (Format, Var); + end Decimal_Format; + + ----------------- + -- Enum_Format -- + ----------------- + + function Enum_Format + (Format : Formatted_String; + Var : Enum) return Formatted_String is + begin + return Format & Enum'Image (Var); + end Enum_Format; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (F : in out Formatted_String) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Data, Data_Access); + + D : Data_Access := F.D; + + begin + F.D := null; + + D.Ref_Count := D.Ref_Count - 1; + + if D.Ref_Count = 0 then + Unchecked_Free (D); + end if; + end Finalize; + + ------------------ + -- Fixed_Format -- + ------------------ + + function Fixed_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + function Flt_Format is new P_Flt_Format (Flt, Put); + begin + return Flt_Format (Format, Var); + end Fixed_Format; + + ---------------- + -- Flt_Format -- + ---------------- + + function Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + function Flt_Format is new P_Flt_Format (Flt, Put); + begin + return Flt_Format (Format, Var); + end Flt_Format; + + ------------------- + -- Get_Formatted -- + ------------------- + + function Get_Formatted + (F_Spec : F_Data; + Value : String; + Len : Positive) return String + is + use Ada.Strings.Fixed; + + Res : Unbounded_String; + S : Positive := Value'First; + + begin + -- Handle the flags + + if F_Spec.Kind in Is_Number then + if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then + Append (Res, "+"); + elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then + Append (Res, " "); + end if; + + if Value (Value'First) = '-' then + Append (Res, "-"); + S := S + 1; + end if; + end if; + + -- Zero padding if required and possible + + if F_Spec.Left_Justify = False + and then F_Spec.Zero_Pad + and then F_Spec.Width > Len + Value'First - S + then + Append (Res, String'((F_Spec.Width - Len + Value'First - S) * '0')); + end if; + + -- Add the value now + + Append (Res, Value (S .. Value'Last)); + + declare + R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len), + Length (Res))) := (others => ' '); + begin + if F_Spec.Left_Justify then + R (1 .. Length (Res)) := To_String (Res); + else + R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res); + end if; + + return R; + end; + end Get_Formatted; + + ---------------- + -- Int_Format -- + ---------------- + + function Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String + is + function Sign (Var : Int) return Sign_Kind is + (if Var < 0 then Neg elsif Var = 0 then Zero else Pos); + + function To_Integer (Var : Int) return Integer is + (Integer (Var)); + + function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put); + + begin + return Int_Format (Format, Var); + end Int_Format; + + ---------------- + -- Mod_Format -- + ---------------- + + function Mod_Format + (Format : Formatted_String; + Var : Int) return Formatted_String + is + function Sign (Var : Int) return Sign_Kind is + (if Var < 0 then Neg elsif Var = 0 then Zero else Pos); + + function To_Integer (Var : Int) return Integer is + (Integer (Var)); + + function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put); + + begin + return Int_Format (Format, Var); + end Mod_Format; + + ----------------- + -- Next_Format -- + ----------------- + + procedure Next_Format + (Format : Formatted_String; + F_Spec : out F_Data; + Start : out Positive) + is + F : String renames Format.D.Format; + J : Natural renames Format.D.Index; + S : Natural; + Width_From_Var : Boolean := False; + + begin + Format.D.Current := Format.D.Current + 1; + F_Spec.Value_Needed := 0; + + -- Got to next % + + while (J <= F'Last and then F (J) /= '%') + or else (J < F'Last - 1 and then F (J + 1) = '%') + loop + Append (Format.D.Result, F (J)); + + -- If we have two consecutive %, skip the second one + + if F (J) = '%' and then J < F'Last - 1 and then F (J + 1) = '%' then + J := J + 1; + end if; + + J := J + 1; + end loop; + + if F (J) /= '%' or else J = F'Last then + raise Format_Error with "no format specifier found for parameter" + & Positive'Image (Format.D.Current); + end if; + + Start := J; + + J := J + 1; + + -- Check for any flags + + Flags_Check : while J < F'Last loop + if F (J) = '-' then + F_Spec.Left_Justify := True; + elsif F (J) = '+' then + F_Spec.Sign := Forced; + elsif F (J) = ' ' then + F_Spec.Sign := Space; + elsif F (J) = '#' then + F_Spec.Base := C_Style; + elsif F (J) = '~' then + F_Spec.Base := Ada_Style; + elsif F (J) = '0' then + F_Spec.Zero_Pad := True; + else + exit Flags_Check; + end if; + + J := J + 1; + end loop Flags_Check; + + -- Check width if any + + if F (J) in '0' .. '9' then + + -- We have a width parameter + + S := J; + + while J < F'Last and then F (J + 1) in '0' .. '9' loop + J := J + 1; + end loop; + + F_Spec.Width := Natural'Value (F (S .. J)); + + J := J + 1; + + elsif F (J) = '*' then + + -- The width will be taken from the integer parameter + + F_Spec.Value_Needed := 1; + Width_From_Var := True; + + J := J + 1; + end if; + + if F (J) = '.' then + + -- We have a precision parameter + + J := J + 1; + + if F (J) in '0' .. '9' then + S := J; + + while J < F'Length and then F (J + 1) in '0' .. '9' loop + J := J + 1; + end loop; + + if F (J) = '.' then + + -- No precision, 0 is assumed + + F_Spec.Precision := 0; + + else + F_Spec.Precision := Natural'Value (F (S .. J)); + end if; + + J := J + 1; + + elsif F (J) = '*' then + + -- The prevision will be taken from the integer parameter + + F_Spec.Value_Needed := F_Spec.Value_Needed + 1; + J := J + 1; + end if; + end if; + + -- Skip the length specifier, this is not needed for this implementation + -- but yet for compatibility reason it is handled. + + Length_Check : + while J <= F'Last + and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L' + loop + J := J + 1; + end loop Length_Check; + + if J > F'Last then + Raise_Wrong_Format (Format); + end if; + + -- Read next character which should be the expected type + + case F (J) is + when 'c' => F_Spec.Kind := Char; + when 's' => F_Spec.Kind := Str; + when 'd' | 'i' => F_Spec.Kind := Decimal_Int; + when 'u' => F_Spec.Kind := Unsigned_Decimal_Int; + when 'f' | 'F' => F_Spec.Kind := Decimal_Float; + when 'e' => F_Spec.Kind := Decimal_Scientific_Float; + when 'E' => F_Spec.Kind := Decimal_Scientific_Float_Up; + when 'g' => F_Spec.Kind := Shortest_Decimal_Float; + when 'G' => F_Spec.Kind := Shortest_Decimal_Float_Up; + when 'o' => F_Spec.Kind := Unsigned_Octal; + when 'x' => F_Spec.Kind := Unsigned_Hexadecimal_Int; + when 'X' => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up; + + when others => + raise Format_Error with "unknown format specified for parameter" + & Positive'Image (Format.D.Current); + end case; + + J := J + 1; + + if F_Spec.Value_Needed > 0 + and then F_Spec.Value_Needed = Format.D.Stored_Value + then + if F_Spec.Value_Needed = 1 then + if Width_From_Var then + F_Spec.Width := Format.D.Stack (1); + else + F_Spec.Precision := Format.D.Stack (1); + end if; + + else + F_Spec.Width := Format.D.Stack (1); + F_Spec.Precision := Format.D.Stack (2); + end if; + end if; + end Next_Format; + + ------------------ + -- P_Flt_Format -- + ------------------ + + function P_Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + F : F_Data; + Buffer : String (1 .. 50); + S, E : Positive := 1; + Start : Positive; + Aft : Text_IO.Field; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + if F.Precision = Unset then + Aft := 6; + else + Aft := F.Precision; + end if; + + case F.Kind is + when Decimal_Float => + + Put (Buffer, Var, Aft, Exp => 0); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + when Decimal_Scientific_Float | Decimal_Scientific_Float_Up => + + Put (Buffer, Var, Aft, Exp => 3); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + if F.Kind = Decimal_Scientific_Float then + Buffer (S .. E) := + Characters.Handling.To_Lower (Buffer (S .. E)); + end if; + + when Shortest_Decimal_Float | Shortest_Decimal_Float_Up => + + -- Without exponent + + Put (Buffer, Var, Aft, Exp => 0); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + -- Check with exponent + + declare + Buffer2 : String (1 .. 50); + S2, E2 : Positive; + + begin + Put (Buffer2, Var, Aft, Exp => 3); + S2 := Strings.Fixed.Index_Non_Blank (Buffer2); + E2 := Buffer2'Last; + + -- If with exponent it is shorter, use it + + if (E2 - S2) < (E - S) then + Buffer := Buffer2; + S := S2; + E := E2; + end if; + end; + + if F.Kind = Shortest_Decimal_Float then + Buffer (S .. E) := + Characters.Handling.To_Lower (Buffer (S .. E)); + end if; + + when others => + Raise_Wrong_Format (Format); + end case; + + Append (Format.D.Result, + Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length)); + + return Format; + end P_Flt_Format; + + ------------------ + -- P_Int_Format -- + ------------------ + + function P_Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String + is + function Handle_Precision return Boolean; + -- Return True if nothing else to do + + F : F_Data; + Buffer : String (1 .. 50); + S, E : Positive := 1; + Len : Natural := 0; + Start : Positive; + + ---------------------- + -- Handle_Precision -- + ---------------------- + + function Handle_Precision return Boolean is + begin + if F.Precision = 0 and then Sign (Var) = Zero then + return True; + + elsif F.Precision = Natural'Last then + null; + + elsif F.Precision > E - S + 1 then + Len := F.Precision - (E - S + 1); + Buffer (S - Len .. S - 1) := (others => '0'); + S := S - Len; + end if; + + return False; + end Handle_Precision; + + -- Start of processing for P_Int_Format + + begin + Next_Format (Format, F, Start); + + if Format.D.Stored_Value < F.Value_Needed then + Format.D.Stored_Value := Format.D.Stored_Value + 1; + Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var); + Format.D.Index := Start; + return Format; + end if; + + case F.Kind is + when Unsigned_Octal => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 8); + S := Strings.Fixed.Index (Buffer, "8#") + 2; + E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; + + if Handle_Precision then + return Format; + end if; + + case F.Base is + when None => null; + when C_Style => Len := 1; + when Ada_Style => Len := 3; + end case; + + when Unsigned_Hexadecimal_Int => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 16); + S := Strings.Fixed.Index (Buffer, "16#") + 3; + E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; + Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E)); + + if Handle_Precision then + return Format; + end if; + + case F.Base is + when None => null; + when C_Style => Len := 2; + when Ada_Style => Len := 4; + end case; + + when Unsigned_Hexadecimal_Int_Up => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 16); + S := Strings.Fixed.Index (Buffer, "16#") + 3; + E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; + + if Handle_Precision then + return Format; + end if; + + case F.Base is + when None => null; + when C_Style => Len := 2; + when Ada_Style => Len := 4; + end case; + + when Unsigned_Decimal_Int => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 10); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + if Handle_Precision then + return Format; + end if; + + when Decimal_Int => + Put (Buffer, Var, Base => 10); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + if Handle_Precision then + return Format; + end if; + + when Char => + S := Buffer'First; + E := Buffer'First; + Buffer (S) := Character'Val (To_Integer (Var)); + + if Handle_Precision then + return Format; + end if; + + when others => + Raise_Wrong_Format (Format); + end case; + + -- Then add base if needed + + declare + N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len); + P : constant Positive := + (if F.Left_Justify + then N'First + else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1, + N'First)); + begin + case F.Base is + when None => + null; + + when C_Style => + case F.Kind is + when Unsigned_Octal => + N (P) := 'O'; + + when Unsigned_Hexadecimal_Int => + if F.Left_Justify then + N (P .. P + 1) := "Ox"; + else + N (P - 1 .. P) := "0x"; + end if; + + when Unsigned_Hexadecimal_Int_Up => + if F.Left_Justify then + N (P .. P + 1) := "OX"; + else + N (P - 1 .. P) := "0X"; + end if; + + when others => + null; + end case; + + when Ada_Style => + case F.Kind is + when Unsigned_Octal => + if F.Left_Justify then + N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2); + else + N (P .. N'Last - 1) := N (P + 1 .. N'Last); + end if; + + N (N'First .. N'First + 1) := "8#"; + N (N'Last) := '#'; + + 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 + N (P .. N'Last - 1) := N (P + 1 .. N'Last); + end if; + + N (N'First .. N'First + 2) := "16#"; + N (N'Last) := '#'; + + when others => + null; + end case; + end case; + + Append (Format.D.Result, N); + end; + + return Format; + end P_Int_Format; + + ------------------------ + -- Raise_Wrong_Format -- + ------------------------ + + procedure Raise_Wrong_Format (Format : Formatted_String) is + begin + raise Format_Error with + "wrong format specified for parameter" + & Positive'Image (Format.D.Current); + end Raise_Wrong_Format; + +end GNAT.Formatted_String; diff --git a/main/gcc/ada/g-forstr.ads b/main/gcc/ada/g-forstr.ads new file mode 100644 index 00000000000..94c295c7251 --- /dev/null +++ b/main/gcc/ada/g-forstr.ads @@ -0,0 +1,294 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . F O R M A T T E D _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014, Free Software Foundation, Inc. -- +-- -- +-- GNAT is 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package add support for formatted string as supported by C printf(). + +-- A simple usage is: + +-- declare +-- F : Formatted_String := +"['%c' ; %10d]"; +-- C : Character := 'v'; +-- I : Integer := 98; +-- begin +-- F := F & C & I; +-- Put_Line (-F); +-- end; + +-- Which will display: + +-- ['v' ; 98] + +-- Each format specifier is: %[flags][width][.precision][length]specifier + +-- Specifiers: +-- d or i Signed decimal integer +-- u Unsigned decimal integer +-- o Unsigned octal +-- x Unsigned hexadecimal integer +-- X Unsigned hexadecimal integer (uppercase) +-- f Decimal floating point, lowercase +-- F Decimal floating point, uppercase +-- e Scientific notation (mantissa/exponent), lowercase +-- E Scientific notation (mantissa/exponent), uppercase +-- g Use the shortest representation: %e or %f +-- G Use the shortest representation: %E or %F +-- c Character +-- s String of characters +-- p Pointer address +-- % A % followed by another % character will write a single % + +-- Flags: + +-- - Left-justify within the given field width; +-- Right justification is the default. + +-- + Forces to preceed the result with a plus or minus sign (+ or -) +-- even for positive numbers. By default, only negative numbers +-- are preceded with a - sign. + +-- (space) If no sign is going to be written, a blank space is inserted +-- before the value. + +-- # Used with o, x or X specifiers the value is preceeded with +-- 0, 0x or 0X respectively for values different than zero. +-- Used with a, A, e, E, f, F, g or G it forces the written +-- output to contain a decimal point even if no more digits +-- follow. By default, if no digits follow, no decimal point is +-- written. + +-- ~ As above, but using Ada style based ## + +-- 0 Left-pads the number with zeroes (0) instead of spaces when +-- padding is specified. + +-- Width: +-- number Minimum number of characters to be printed. If the value to +-- be printed is shorter than this number, the result is padded +-- with blank spaces. The value is not truncated even if the +-- result is larger. + +-- * The width is not specified in the format string, but as an +-- additional integer value argument preceding the argument that +-- has to be formatted. +-- Precision: +-- number For integer specifiers (d, i, o, u, x, X): precision specifies +-- the minimum number of digits to be written. If the value to be +-- written is shorter than this number, the result is padded with +-- leading zeros. The value is not truncated even if the result +-- is longer. A precision of 0 means that no character is written +-- for the value 0. + +-- For e, E, f and F specifiers: this is the number of digits to +-- be printed after the decimal point (by default, this is 6). +-- For g and G specifiers: This is the maximum number of +-- significant digits to be printed. + +-- For s: this is the maximum number of characters to be printed. +-- By default all characters are printed until the ending null +-- character is encountered. + +-- If the period is specified without an explicit value for +-- precision, 0 is assumed. + +-- .* The precision is not specified in the format string, but as an +-- additional integer value argument preceding the argument that +-- has to be formatted. + +with Ada.Text_IO; +with System; + +private with Ada.Finalization; +private with Ada.Strings.Unbounded; + +package GNAT.Formatted_String is + use Ada; + + type Formatted_String (<>) is private; + -- A format string as defined for printf routine + + Format_Error : exception; + -- Raised for every mismatch between the parameter and the expected format + -- and for malformed format. + + function "+" (Format : String) return Formatted_String; + -- Create the format string + + function "-" (Format : Formatted_String) return String; + -- Get the result of the formatted string corresponding to the current + -- rendering (up to the last parameter formated). + + function "&" + (Format : Formatted_String; + Var : Character) return Formatted_String; + -- A character, expect a %c + + function "&" + (Format : Formatted_String; + Var : String) return Formatted_String; + -- A string, expect a %s + + function "&" + (Format : Formatted_String; + Var : Boolean) return Formatted_String; + -- A boolean image, expect a %s + + function "&" + (Format : Formatted_String; + Var : Integer) return Formatted_String; + -- An integer, expect a %d, %o, %x, %X + + function "&" + (Format : Formatted_String; + Var : Long_Integer) return Formatted_String; + -- As above + + function "&" + (Format : Formatted_String; + Var : System.Address) return Formatted_String; + -- An address, expect a %p + + function "&" + (Format : Formatted_String; + Var : Float) return Formatted_String; + -- A float, expect %f, %e, %F, %E, %g, %G + + function "&" + (Format : Formatted_String; + Var : Long_Float) return Formatted_String; + -- As above + + function "&" + (Format : Formatted_String; + Var : Duration) return Formatted_String; + -- As above + + -- Some generics + + generic + type Int is range <>; + + with procedure Put + (To : out String; + Item : Int; + Base : Text_IO.Number_Base); + function Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String; + -- As for Integer above + + generic + type Int is mod <>; + + with procedure Put + (To : out String; + Item : Int; + Base : Text_IO.Number_Base); + function Mod_Format + (Format : Formatted_String; + Var : Int) return Formatted_String; + -- As for Integer above + + generic + type Flt is digits <>; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- As for Float above + + generic + type Flt is delta <>; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function Fixed_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- As for Float above + + generic + type Flt is delta <> digits <>; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function Decimal_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- As for Float above + + generic + type Enum is (<>); + function Enum_Format + (Format : Formatted_String; + Var : Enum) return Formatted_String; + -- As for String above, output the string representation of the enumeration + +private + use Ada.Strings.Unbounded; + + type I_Vars is array (Positive range 1 .. 2) of Integer; + -- Used to keep 2 numbers for the possible * for the width and precision + + type Data (Size : Natural) is record + Ref_Count : Natural := 1; + Format : String (1 .. Size); -- the format string + Index : Positive := 1; -- format index for next value + Result : Unbounded_String; -- current value + Current : Natural; -- the current format number + Stored_Value : Natural := 0; -- number of stored values in Stack + Stack : I_Vars; + end record; + + type Data_Access is access Data; + + -- The formatted string record is controlled and do not need an initialize + -- as it requires an explit initial value. This is given with "+" and + -- properly initialize the record at this point. + + type Formatted_String is new Finalization.Controlled with record + D : Data_Access; + end record; + + overriding procedure Adjust (F : in out Formatted_String); + overriding procedure Finalize (F : in out Formatted_String); + +end GNAT.Formatted_String; diff --git a/main/gcc/ada/g-sechas.adb b/main/gcc/ada/g-sechas.adb index 4b396f112ed..0e70b5dd48f 100644 --- a/main/gcc/ada/g-sechas.adb +++ b/main/gcc/ada/g-sechas.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -218,8 +218,8 @@ package body GNAT.Secure_Hashes is -- the message size in bits (excluding padding). procedure Final - (C : Context; - Hash_Bits : out Stream_Element_Array) + (C : Context; + Hash_Bits : out Stream_Element_Array) is FC : Context := C; @@ -274,8 +274,73 @@ package body GNAT.Secure_Hashes is pragma Assert (FC.M_State.Last = 0); Hash_State.To_Hash (FC.H_State, Hash_Bits); + + -- HMAC case: hash outer pad + + if C.KL /= 0 then + declare + Outer_C : Context; + Opad : Stream_Element_Array := + (1 .. Stream_Element_Offset (Block_Length) => 16#5c#); + + begin + for J in C.Key'Range loop + Opad (J) := Opad (J) xor C.Key (J); + end loop; + + Update (Outer_C, Opad); + Update (Outer_C, Hash_Bits); + + Final (Outer_C, Hash_Bits); + end; + end if; end Final; + -------------------------- + -- HMAC_Initial_Context -- + -------------------------- + + function HMAC_Initial_Context (Key : String) return Context is + begin + if Key'Length = 0 then + raise Constraint_Error with "null key"; + end if; + + return C : Context (KL => (if Key'Length <= Key_Length'Last + then Key'Length + else Stream_Element_Offset (Hash_Length))) + do + -- Set Key (if longer than block length, first hash it) + + if C.KL = Key'Length then + declare + SK : String (1 .. Key'Length); + for SK'Address use C.Key'Address; + pragma Import (Ada, SK); + begin + SK := Key; + end; + + else + C.Key := Digest (Key); + end if; + + -- Hash inner pad + + declare + Ipad : Stream_Element_Array := + (1 .. Stream_Element_Offset (Block_Length) => 16#36#); + + begin + for J in C.Key'Range loop + Ipad (J) := Ipad (J) xor C.Key (J); + end loop; + + Update (C, Ipad); + end; + end return; + end HMAC_Initial_Context; + ------------ -- Update -- ------------ @@ -285,11 +350,12 @@ package body GNAT.Secure_Hashes is S : String; Fill_Buffer : Fill_Buffer_Access) is - Last : Natural := S'First - 1; + Last : Natural; begin C.M_State.Length := C.M_State.Length + S'Length; + Last := S'First - 1; while Last < S'Last loop Fill_Buffer (C.M_State, S, Last + 1, Last); diff --git a/main/gcc/ada/g-sechas.ads b/main/gcc/ada/g-sechas.ads index f3f71601de5..c00150e17ba 100644 --- a/main/gcc/ada/g-sechas.ads +++ b/main/gcc/ada/g-sechas.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -144,6 +144,9 @@ package GNAT.Secure_Hashes is -- Initial value of a Context object. May be used to reinitialize -- a Context value by simple assignment of this value to the object. + function HMAC_Initial_Context (Key : String) return Context; + -- Initial Context for HMAC computation with the given Key + procedure Update (C : in out Context; Input : String); procedure Wide_Update (C : in out Context; Input : Wide_String); procedure Update @@ -163,7 +166,7 @@ package GNAT.Secure_Hashes is -- the hash in binary representation. function Digest (C : Context) return Binary_Message_Digest; - -- Return hash for the data accumulated with C + -- Return hash or HMAC for the data accumulated with C function Digest (S : String) return Binary_Message_Digest; function Wide_Digest (W : Wide_String) return Binary_Message_Digest; @@ -178,7 +181,7 @@ package GNAT.Secure_Hashes is -- hexadecimal representation. function Digest (C : Context) return Message_Digest; - -- Return hash for the data accumulated with C in hexadecimal + -- Return hash or HMAC for the data accumulated with C in hexadecimal -- representation. function Digest (S : String) return Message_Digest; @@ -193,7 +196,15 @@ package GNAT.Secure_Hashes is Block_Length : constant Natural := Block_Words * Word_Length; -- Length in bytes of a data block - type Context is record + subtype Key_Length is + Stream_Element_Offset range 0 .. Stream_Element_Offset (Block_Length); + + -- KL is 0 for a normal hash context, > 0 for HMAC + + type Context (KL : Key_Length := 0) is record + Key : Stream_Element_Array (1 .. KL); + -- HMAC key + H_State : Hash_State.State (0 .. State_Words - 1) := Initial_State; -- Function-specific state @@ -201,7 +212,7 @@ package GNAT.Secure_Hashes is -- Function-independent state (block buffer) end record; - Initial_Context : constant Context := (others => <>); + Initial_Context : constant Context (KL => 0) := (others => <>); -- Initial values are provided by default initialization of Context end H; diff --git a/main/gcc/ada/g-socket.adb b/main/gcc/ada/g-socket.adb index ee4d52a4cca..94125173515 100644 --- a/main/gcc/ada/g-socket.adb +++ b/main/gcc/ada/g-socket.adb @@ -34,8 +34,6 @@ with Ada.Exceptions; use Ada.Exceptions; with Ada.Finalization; with Ada.Unchecked_Conversion; -with Interfaces.C.Strings; - with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; @@ -174,8 +172,7 @@ package body GNAT.Sockets is -- Conversion function function Value (S : System.Address) return String; - -- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS, - -- chars_ptr is a 32-bit pointer, and here we need a 64-bit version). + -- Same as Interfaces.C.Strings.Value but taking a System.Address function To_Timeval (Val : Timeval_Duration) return Timeval; -- Separate Val in seconds and microseconds @@ -1412,7 +1409,6 @@ package body GNAT.Sockets is function Inet_Addr (Image : String) return Inet_Addr_Type is use Interfaces.C; - use Interfaces.C.Strings; Img : aliased char_array := To_C (Image); Addr : aliased C.int; @@ -1710,7 +1706,6 @@ package body GNAT.Sockets is ------------------------ procedure Raise_Socket_Error (Error : Integer) is - use type C.Strings.chars_ptr; begin raise Socket_Error with Err_Code_Image (Error) & Socket_Error_Message (Error); @@ -2421,7 +2416,6 @@ package body GNAT.Sockets is function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is use type C.size_t; - use C.Strings; Aliases_Count, Addresses_Count : Natural; @@ -2549,7 +2543,6 @@ package body GNAT.Sockets is ---------------------- function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is - use C.Strings; use type C.size_t; Aliases_Count : Natural; diff --git a/main/gcc/ada/g-socket.ads b/main/gcc/ada/g-socket.ads index 7df5af0eeee..517dd4f510a 100644 --- a/main/gcc/ada/g-socket.ads +++ b/main/gcc/ada/g-socket.ads @@ -39,9 +39,6 @@ -- feature, so it is not available if Multicast is not supported, or not -- installed. --- The VMS implementation was implemented using the DECC RTL Socket API, --- and is thus subject to limitations in the implementation of this API. - -- VxWorks cross ports fully implement this package -- This package is not yet implemented on LynxOS or other cross ports @@ -797,7 +794,7 @@ package GNAT.Sockets is type Vector_Element is record Base : Stream_Element_Reference; - Length : Ada.Streams.Stream_Element_Count; + Length : Interfaces.C.size_t; end record; type Vector_Type is array (Integer range <>) of Vector_Element; diff --git a/main/gcc/ada/g-socthi-mingw.adb b/main/gcc/ada/g-socthi-mingw.adb index 719ab547755..e8ee6dcc630 100644 --- a/main/gcc/ada/g-socthi-mingw.adb +++ b/main/gcc/ada/g-socthi-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, AdaCore -- +-- Copyright (C) 2001-2014, 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- -- @@ -35,7 +35,6 @@ -- This version is for NT -with Ada.Streams; use Ada.Streams; with Ada.Unchecked_Conversion; with Interfaces.C.Strings; use Interfaces.C.Strings; with System; use System; @@ -334,11 +333,11 @@ package body GNAT.Sockets.Thin is exit; else - pragma Assert (Stream_Element_Count (Res) <= Current_Iovec.Length); + pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); Count := Count + Res; Current_Iovec.Length := - Current_Iovec.Length - Stream_Element_Count (Res); + Current_Iovec.Length - Interfaces.C.size_t (Res); Current_Iovec.Base := To_Access (Current_Iovec.Base.all'Address + Storage_Offset (Res)); @@ -507,7 +506,7 @@ package body GNAT.Sockets.Thin is -- Exit now if the buffer is not fully transmitted - exit when Stream_Element_Count (Res) < Iovec (J).Length; + exit when Interfaces.C.size_t (Res) < Iovec (J).Length; end loop; return System.CRTL.ssize_t (Count); diff --git a/main/gcc/ada/g-socthi-vms.adb b/main/gcc/ada/g-socthi-vms.adb deleted file mode 100644 index 4005cd30787..00000000000 --- a/main/gcc/ada/g-socthi-vms.adb +++ /dev/null @@ -1,502 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2013, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the version for OpenVMS - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin is - - type VMS_Msghdr is new Msghdr; - pragma Pack (VMS_Msghdr); - -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a - -- specific derived type is required. This structure was not packed on - -- VMS 7.3. - - function Is_VMS_V7 return Integer; - pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7"); - -- Helper (defined in init.c) that returns a non-zero value if the VMS - -- version is 7.x. - - VMS_V7 : constant Boolean := Is_VMS_V7 /= 0; - -- True if VMS version is 7.x. - - Non_Blocking_Sockets : aliased Fd_Set; - -- When this package is initialized with Process_Blocking_IO set to True, - -- sockets are set in non-blocking mode to avoid blocking the whole process - -- when a thread wants to perform a blocking IO operation. But the user can - -- also set a socket in non-blocking mode by purpose. In order to make a - -- difference between these two situations, we track the origin of - -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in - -- Non_Blocking_Sockets, it has been set in non-blocking mode by the user. - - Quantum : constant Duration := 0.2; - -- When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking - -- mode and we spend a period of time Quantum between two attempts on a - -- blocking operation. - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Accept, "accept"); - - function Syscall_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (C, Syscall_Connect, "connect"); - - function Syscall_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recv, "recv"); - - function Syscall_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recvmsg, "recvmsg"); - - function Syscall_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Sendmsg, "sendmsg"); - - function Syscall_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - pragma Import (C, Syscall_Sendto, "sendto"); - - function Syscall_Socket - (Domain, Typ, Protocol : C.int) return C.int; - pragma Import (C, Syscall_Socket, "socket"); - - function Non_Blocking_Socket (S : C.int) return Boolean; - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); - - -------------- - -- C_Accept -- - -------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Discard : C.int; - pragma Warnings (Off, Discard); - - begin - loop - R := Syscall_Accept (S, Addr, Addrlen); - exit when SOSC.Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties of its server, especially - -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - end if; - - return R; - end C_Accept; - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Syscall_Connect (S, Name, Namelen); - - if SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EINPROGRESS - then - return Res; - end if; - - declare - WSet : aliased Fd_Set; - Now : aliased Timeval; - - begin - Reset_Socket_Set (WSet'Access); - loop - Insert_Socket_In_Set (WSet'Access, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set_Access, - WSet'Access, - No_Fd_Set_Access, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - return Res; - end if; - - delay Quantum; - end loop; - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure and then Errno = SOSC.EISCONN then - return Thin_Common.Success; - else - return Res; - end if; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return C_Ioctl (S, Req, Arg); - end Socket_Ioctl; - - ------------ - -- C_Recv -- - ------------ - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recv (S, Msg, Len, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recv; - - ---------------- - -- C_Recvfrom -- - ---------------- - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - Msg_Addr : System.Address; - - GNAT_Msg : Msghdr; - for GNAT_Msg'Address use Msg; - pragma Import (Ada, GNAT_Msg); - - VMS_Msg : aliased VMS_Msghdr; - - begin - if VMS_V7 then - Msg_Addr := Msg; - else - VMS_Msg := VMS_Msghdr (GNAT_Msg); - Msg_Addr := VMS_Msg'Address; - end if; - - loop - Res := Syscall_Recvmsg (S, Msg_Addr, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not VMS_V7 then - GNAT_Msg := Msghdr (VMS_Msg); - end if; - - return System.CRTL.ssize_t (Res); - end C_Recvmsg; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - Msg_Addr : System.Address; - - GNAT_Msg : Msghdr; - for GNAT_Msg'Address use Msg; - pragma Import (Ada, GNAT_Msg); - - VMS_Msg : aliased VMS_Msghdr; - - begin - if VMS_V7 then - Msg_Addr := Msg; - else - VMS_Msg := VMS_Msghdr (GNAT_Msg); - Msg_Addr := VMS_Msg'Address; - end if; - - loop - Res := Syscall_Sendmsg (S, Msg_Addr, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not VMS_V7 then - GNAT_Msg := Msghdr (VMS_Msg); - end if; - - return System.CRTL.ssize_t (Res); - end C_Sendmsg; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Sendto; - - -------------- - -- C_Socket -- - -------------- - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Discard : C.int; - pragma Unreferenced (Discard); - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- Do not use Socket_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - Set_Non_Blocking_Socket (R, False); - end if; - - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is separate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Reset_Socket_Set (Non_Blocking_Sockets'Access); - end Initialize; - - ------------------------- - -- Non_Blocking_Socket -- - ------------------------- - - function Non_Blocking_Socket (S : C.int) return Boolean is - R : Boolean; - begin - Task_Lock.Lock; - R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------------------- - -- Set_Non_Blocking_Socket -- - ----------------------------- - - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is - begin - Task_Lock.Lock; - - if V then - Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is separate; - -end GNAT.Sockets.Thin; diff --git a/main/gcc/ada/g-socthi-vms.ads b/main/gcc/ada/g-socthi-vms.ads deleted file mode 100644 index 25c58705703..00000000000 --- a/main/gcc/ada/g-socthi-vms.ads +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2013, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the Alpha/VMS version - -with Interfaces.C; - -with GNAT.OS_Lib; -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - -- ??? more comments needed ??? - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; - -- Returns last socket error number - - procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno; - -- Set last socket error number - - function Socket_Error_Message (Errno : Integer) return String; - -- Returns the error message string for the error number Errno. If Errno is - -- not known, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Close - (Fd : C.int) return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : C.int) return C.int; - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - - function C_System - (Command : System.Address) return C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - ------------------------------------------- - -- Nonreentrant network databases access -- - ------------------------------------------- - - function Nonreentrant_Gethostbyname - (Name : C.char_array) return Hostent_Access; - - function Nonreentrant_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int) return Hostent_Access; - - function Nonreentrant_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access; - - function Nonreentrant_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access; - - procedure Initialize; - procedure Finalize; - -private - - pragma Import (C, C_Bind, "DECC$BIND"); - pragma Import (C, C_Close, "DECC$CLOSE"); - pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); - pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); - pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); - pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); - pragma Import (C, C_Listen, "DECC$LISTEN"); - pragma Import (C, C_Select, "DECC$SELECT"); - pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); - pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); - pragma Import (C, C_System, "DECC$SYSTEM"); - - pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); - pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR"); - pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME"); - pragma Import (C, Nonreentrant_Getservbyport, "DECC$GETSERVBYPORT"); - -end GNAT.Sockets.Thin; diff --git a/main/gcc/ada/g-socthi.adb b/main/gcc/ada/g-socthi.adb index 76d82a8a413..6f6fd376968 100644 --- a/main/gcc/ada/g-socthi.adb +++ b/main/gcc/ada/g-socthi.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, AdaCore -- +-- Copyright (C) 2001-2014, 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- -- @@ -383,7 +383,6 @@ package body GNAT.Sockets.Thin is Val : aliased C.int := 1; Discard : C.int; - pragma Unreferenced (Discard); begin R := Syscall_Socket (Domain, Typ, Protocol); diff --git a/main/gcc/ada/g-sothco.ads b/main/gcc/ada/g-sothco.ads index b957f225e80..0d77dd75ef9 100644 --- a/main/gcc/ada/g-sothco.ads +++ b/main/gcc/ada/g-sothco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2012, AdaCore -- +-- Copyright (C) 2008-2014, 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- -- @@ -212,11 +212,6 @@ package GNAT.Sockets.Thin_Common is pragma Convention (C, Hostent_Access); -- Access to host entry - -- Note: the hostent and servent accessors that return char* - -- values are compiled with GCC, and on VMS they always return - -- 64-bit pointers, so we can't use C.Strings.chars_ptr, which - -- on VMS is 32 bits. - function Hostent_H_Name (E : Hostent_Access) return System.Address; diff --git a/main/gcc/ada/g-souinf.ads b/main/gcc/ada/g-souinf.ads index 8810f4db07f..610db233718 100644 --- a/main/gcc/ada/g-souinf.ads +++ b/main/gcc/ada/g-souinf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,15 +46,18 @@ package GNAT.Source_Info is -- Historical note: this used to be Pure, but that was when we marked all -- intrinsics as not Pure, even in Pure units, so no problems arose. - function File return String; + function File return String with + Import, Convention => Intrinsic; -- Return the name of the current file, not including the path information. -- The result is considered to be a static string constant. - function Line return Positive; + function Line return Positive with + Import, Convention => Intrinsic; -- Return the current input line number. The result is considered to be a -- static expression. - function Source_Location return String; + function Source_Location return String with + Import, Convention => Intrinsic; -- Return a string literal of the form "name:line", where name is the -- current source file name without path information, and line is the -- current line number. In the event that instantiations are involved, @@ -62,7 +65,8 @@ package GNAT.Source_Info is -- string " instantiated at ". The result is considered to be a static -- string constant. - function Enclosing_Entity return String; + function Enclosing_Entity return String with + Import, Convention => Intrinsic; -- Return the name of the current subprogram, package, task, entry or -- protected subprogram. The string is in exactly the form used for the -- declaration of the entity (casing and encoding conventions), and is @@ -75,9 +79,14 @@ package GNAT.Source_Info is -- package itself. This is useful in identifying and logging information -- from within generic templates. -private - pragma Import (Intrinsic, File); - pragma Import (Intrinsic, Line); - pragma Import (Intrinsic, Source_Location); - pragma Import (Intrinsic, Enclosing_Entity); + function Compilation_Date return String with + Import, Convention => Intrinsic; + -- Returns date of compilation as a static string "mmm dd yyyy". This is + -- in local time form, and is exactly compatible with C macro __DATE__. + + function Compilation_Time return String with + Import, Convention => Intrinsic; + -- Returns GMT time of compilation as a static string "hh:mm:ss". This is + -- in local time form, and is exactly compatible with C macro __TIME__. + end GNAT.Source_Info; diff --git a/main/gcc/ada/g-strspl.ads b/main/gcc/ada/g-strspl.ads index 746ab83023f..31851b3ee09 100644 --- a/main/gcc/ada/g-strspl.ads +++ b/main/gcc/ada/g-strspl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/g-timsta.adb b/main/gcc/ada/g-timsta.adb index f188b68bc12..50d4f702324 100644 --- a/main/gcc/ada/g-timsta.adb +++ b/main/gcc/ada/g-timsta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2008-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/g-timsta.ads b/main/gcc/ada/g-timsta.ads index 094ccb5bf56..8f35e7b959f 100644 --- a/main/gcc/ada/g-timsta.ads +++ b/main/gcc/ada/g-timsta.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2008-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/g-traceb.adb b/main/gcc/ada/g-traceb.adb index 790115f591b..157d8b620cd 100644 --- a/main/gcc/ada/g-traceb.adb +++ b/main/gcc/ada/g-traceb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -44,7 +44,7 @@ package body GNAT.Traceback is Len : out Natural) is begin - System.Traceback.Call_Chain (Traceback'Address, Traceback'Length, Len); + System.Traceback.Call_Chain (Traceback, Traceback'Length, Len); end Call_Chain; end GNAT.Traceback; diff --git a/main/gcc/ada/g-traceb.ads b/main/gcc/ada/g-traceb.ads index debb0c40341..98d11a8ef99 100644 --- a/main/gcc/ada/g-traceb.ads +++ b/main/gcc/ada/g-traceb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2012, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -63,8 +63,6 @@ -- LynxOS x86 -- Solaris x86 -- Solaris sparc --- OpenVMS/Alpha --- OpenVMS/ia64 -- VxWorks PowerPC -- VxWorks x86 -- Windows NT/XP diff --git a/main/gcc/ada/g-trasym-vms-alpha.adb b/main/gcc/ada/g-trasym-vms-alpha.adb deleted file mode 100644 index c1ea305cfbf..00000000000 --- a/main/gcc/ada/g-trasym-vms-alpha.adb +++ /dev/null @@ -1,303 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support for Alpha/VMS - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with Interfaces.C; -with System; -with System.Aux_DEC; -with System.Soft_Links; -with System.Traceback_Entries; - -package body GNAT.Traceback.Symbolic is - - pragma Warnings (Off); -- Needs comment ??? - pragma Linker_Options ("--for-linker=sys$library:trace.exe"); - - use Interfaces.C; - use System; - use System.Aux_DEC; - use System.Traceback_Entries; - - subtype User_Arg_Type is Unsigned_Longword; - subtype Cond_Value_Type is Unsigned_Longword; - - type ASCIC is record - Count : unsigned_char; - Data : char_array (1 .. 255); - end record; - pragma Convention (C, ASCIC); - - for ASCIC use record - Count at 0 range 0 .. 7; - Data at 1 range 0 .. 8 * 255 - 1; - end record; - for ASCIC'Size use 8 * 256; - - function Fetch_ASCIC is new Fetch_From_Address (ASCIC); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Dummy_User_Act_Proc - (Msgvec : Address := Null_Address; - Actrtn : Address := Null_Address; - Facnam : Address := Null_Address; - Actprm : User_Arg_Type := 0) return Cond_Value_Type; - -- Dummy routine with SYS$PUTMSG signature - - procedure Symbolize - (Status : out Cond_Value_Type; - Current_PC : Address; - Adjusted_PC : Address; - Current_FP : Address; - Current_R26 : Address; - Image_Name : out Address; - Module_Name : out Address; - Routine_Name : out Address; - Line_Number : out Integer; - Relative_PC : out Address; - Absolute_PC : out Address; - PC_Is_Valid : out Long_Integer; - User_Act_Proc : Address := Dummy_User_Act_Proc'Address; - User_Arg_Value : User_Arg_Type := 0); - -- Comment on above procedure required ??? - - pragma Import (External, Symbolize); - - pragma Import_Valued_Procedure - (Symbolize, "TBK$SYMBOLIZE", - (Cond_Value_Type, Address, Address, Address, Address, - Address, Address, Address, Integer, - Address, Address, Long_Integer, - Address, User_Arg_Type), - (Value, Value, Value, Value, Value, - Reference, Reference, Reference, Reference, - Reference, Reference, Reference, - Value, Value)); - - function Decode_Ada_Name (Encoded_Name : String) return String; - -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing - -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' - - --------------------- - -- Decode_Ada_Name -- - --------------------- - - function Decode_Ada_Name (Encoded_Name : String) return String is - Decoded_Name : String (1 .. Encoded_Name'Length); - Pos : Integer := Encoded_Name'First; - Last : Integer := Encoded_Name'Last; - DPos : Integer := 1; - - begin - if Pos > Last then - return ""; - end if; - - -- Skip leading _ada_ - - if Encoded_Name'Length > 4 - and then Encoded_Name (Pos .. Pos + 4) = "_ada_" - then - Pos := Pos + 5; - end if; - - -- Skip trailing __{DIGIT}+ or ${DIGIT}+ - - if Encoded_Name (Last) in '0' .. '9' then - for J in reverse Pos + 2 .. Last - 1 loop - case Encoded_Name (J) is - when '0' .. '9' => - null; - when '$' => - Last := J - 1; - exit; - when '_' => - if Encoded_Name (J - 1) = '_' then - Last := J - 2; - end if; - exit; - when others => - exit; - end case; - end loop; - end if; - - -- Now just copy encoded name to decoded name, converting "__" to '.' - - while Pos <= Last loop - if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' - and then Pos /= Encoded_Name'First - then - Decoded_Name (DPos) := '.'; - Pos := Pos + 2; - - else - Decoded_Name (DPos) := Encoded_Name (Pos); - Pos := Pos + 1; - end if; - - DPos := DPos + 1; - end loop; - - return Decoded_Name (1 .. DPos - 1); - end Decode_Ada_Name; - - ------------------------- - -- Dummy_User_Act_Proc -- - ------------------------- - - function Dummy_User_Act_Proc - (Msgvec : Address := Null_Address; - Actrtn : Address := Null_Address; - Facnam : Address := Null_Address; - Actprm : User_Arg_Type := 0) return Cond_Value_Type - is - begin - return 0; - end Dummy_User_Act_Proc; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is - Status : Cond_Value_Type; - Image_Name : ASCIC; - Image_Name_Addr : Address; - Module_Name : ASCIC; - Module_Name_Addr : Address; - Routine_Name : ASCIC; - Routine_Name_Addr : Address; - Line_Number : Integer; - Relative_PC : Address; - Absolute_PC : Address; - PC_Is_Valid : Long_Integer; - Return_Address : Address; - Res : String (1 .. 256 * Traceback'Length); - Len : Integer; - - begin - if Traceback'Length > 0 then - Len := 0; - - -- Since image computation is not thread-safe we need task lockout - - System.Soft_Links.Lock_Task.all; - - for J in Traceback'Range loop - Return_Address := - (if J = Traceback'Last then Address_Zero - else PC_For (Traceback (J + 1))); - - Symbolize - (Status, - PC_For (Traceback (J)), - PC_For (Traceback (J)), - PV_For (Traceback (J)), - Return_Address, - Image_Name_Addr, - Module_Name_Addr, - Routine_Name_Addr, - Line_Number, - Relative_PC, - Absolute_PC, - PC_Is_Valid); - - Image_Name := Fetch_ASCIC (Image_Name_Addr); - Module_Name := Fetch_ASCIC (Module_Name_Addr); - Routine_Name := Fetch_ASCIC (Routine_Name_Addr); - - declare - First : Integer := Len + 1; - Last : Integer := First + 80 - 1; - Pos : Integer; - Routine_Name_D : String := Decode_Ada_Name - (To_Ada - (Routine_Name.Data (1 .. size_t (Routine_Name.Count)), - False)); - - begin - Res (First .. Last) := (others => ' '); - - Res (First .. First + Integer (Image_Name.Count) - 1) := - To_Ada - (Image_Name.Data (1 .. size_t (Image_Name.Count)), - False); - - Res (First + 10 .. - First + 10 + Integer (Module_Name.Count) - 1) := - To_Ada - (Module_Name.Data (1 .. size_t (Module_Name.Count)), - False); - - Res (First + 30 .. - First + 30 + Routine_Name_D'Length - 1) := - Routine_Name_D; - - -- If routine name doesn't fit 20 characters, output - -- the line number on next line at 50th position - - if Routine_Name_D'Length > 20 then - Pos := First + 30 + Routine_Name_D'Length; - Res (Pos) := ASCII.LF; - Last := Pos + 80; - Res (Pos + 1 .. Last) := (others => ' '); - Pos := Pos + 51; - else - Pos := First + 50; - end if; - - Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) := - Integer'Image (Line_Number); - - Res (Last) := ASCII.LF; - Len := Last; - end; - end loop; - - System.Soft_Links.Unlock_Task.all; - return Res (1 .. Len); - - else - return ""; - end if; - end Symbolic_Traceback; - - function Symbolic_Traceback (E : Exception_Occurrence) return String is - begin - return Symbolic_Traceback (Tracebacks (E)); - end Symbolic_Traceback; - -end GNAT.Traceback.Symbolic; diff --git a/main/gcc/ada/g-trasym-vms-ia64.adb b/main/gcc/ada/g-trasym-vms-ia64.adb deleted file mode 100644 index 897e2ebb24a..00000000000 --- a/main/gcc/ada/g-trasym-vms-ia64.adb +++ /dev/null @@ -1,345 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support for IA64/VMS - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with System; -with System.Aux_DEC; -with System.Soft_Links; -with System.Traceback_Entries; - -package body GNAT.Traceback.Symbolic is - - use System; - use System.Aux_DEC; - use System.Traceback_Entries; - - subtype Var_String_Buf is String (1 .. 254); - - type Var_String is record - Curlen : Unsigned_Word := 0; - Buf : Var_String_Buf; - end record; - pragma Convention (C, Var_String); - for Var_String'Size use 8 * 256; - - type Descriptor64 is record - Mbo : Unsigned_Word; - Dtype : Unsigned_Byte; - Class : Unsigned_Byte; - Mbmo : Unsigned_Longword; - Maxstrlen : Integer_64; - Pointer : Address; - end record; - pragma Convention (C, Descriptor64); - - subtype Cond_Value_Type is Unsigned_Longword; - - -- TBK_API_PARAM as defined in TBKDEF - - type Tbk_Api_Param is record - Length : Unsigned_Word; - T_Type : Unsigned_Byte; - Version : Unsigned_Byte; - Reserveda : Unsigned_Longword; - Faulting_Pc : Address; - Faulting_Fp : Address; - Filename_Desc : Address; - Library_Module_Desc : Address; - Record_Number : Address; - Image_Desc : Address; - Module_Desc : Address; - Routine_Desc : Address; - Listing_Lineno : Address; - Rel_Pc : Address; - Image_Base_Addr : Address; - Module_Base_Addr : Address; - Malloc_Rtn : Address; - Free_Rtn : Address; - Symbolize_Flags : Address; - Reserved0 : Unsigned_Quadword; - Reserved1 : Unsigned_Quadword; - Reserved2 : Unsigned_Quadword; - end record; - pragma Convention (C, Tbk_Api_Param); - - K_Version : constant Unsigned_Byte := 1; - -- Current API version - - K_Length : constant Unsigned_Word := 152; - -- Length of the parameter - - pragma Compile_Time_Error (Tbk_Api_Param'Size = K_Length * 8, - "Bad length for tbk_api_param"); - -- Sanity check - - function Symbolize (Param : Address) return Cond_Value_Type; - pragma Import (C, Symbolize, "TBK$I64_SYMBOLIZE"); - - function Decode_Ada_Name (Encoded_Name : String) return String; - -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing - -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' - - procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address); - -- Setup descriptor Desc for address Var - - --------------------- - -- Decode_Ada_Name -- - --------------------- - - function Decode_Ada_Name (Encoded_Name : String) return String is - Decoded_Name : String (1 .. Encoded_Name'Length); - Pos : Integer := Encoded_Name'First; - Last : Integer := Encoded_Name'Last; - DPos : Integer := 1; - - begin - if Pos > Last then - return ""; - end if; - - -- Skip leading _ada_ - - if Encoded_Name'Length > 4 - and then Encoded_Name (Pos .. Pos + 4) = "_ada_" - then - Pos := Pos + 5; - end if; - - -- Skip trailing __{DIGIT}+ or ${DIGIT}+ - - if Encoded_Name (Last) in '0' .. '9' then - for J in reverse Pos + 2 .. Last - 1 loop - case Encoded_Name (J) is - when '0' .. '9' => - null; - - when '$' => - Last := J - 1; - exit; - - when '_' => - if Encoded_Name (J - 1) = '_' then - Last := J - 2; - end if; - exit; - - when others => - exit; - end case; - end loop; - end if; - - -- Now just copy encoded name to decoded name, converting "__" to '.' - - while Pos <= Last loop - if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' - and then Pos /= Encoded_Name'First - then - Decoded_Name (DPos) := '.'; - Pos := Pos + 2; - else - Decoded_Name (DPos) := Encoded_Name (Pos); - Pos := Pos + 1; - end if; - - DPos := DPos + 1; - end loop; - - return Decoded_Name (1 .. DPos - 1); - end Decode_Ada_Name; - - --------------------------- - -- Setup_Descriptor64_Vs -- - --------------------------- - - procedure Setup_Descriptor64_Vs (Desc : out Descriptor64; Var : Address) is - K_Dtype_Vt : constant Unsigned_Byte := 37; - K_Class_Vs : constant Unsigned_Byte := 11; - begin - Desc.Mbo := 1; - Desc.Dtype := K_Dtype_Vt; - Desc.Class := K_Class_Vs; - Desc.Mbmo := -1; - Desc.Maxstrlen := Integer_64 (Var_String_Buf'Length); - Desc.Pointer := Var; - end Setup_Descriptor64_Vs; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is - Param : Tbk_Api_Param; - Status : Cond_Value_Type; - Record_Number : Unsigned_Longword; - Image_Name : Var_String; - Image_Dsc : Descriptor64; - Module_Name : Var_String; - Module_Dsc : Descriptor64; - Routine_Name : Var_String; - Routine_Dsc : Descriptor64; - Line_Number : Unsigned_Longword; - Res : String (1 .. 256 * Traceback'Length); - Len : Integer; - - begin - if Traceback'Length = 0 then - return ""; - end if; - - Len := 0; - - -- Since image computation is not thread-safe we need task lockout - - System.Soft_Links.Lock_Task.all; - - -- Initialize descriptors - - Setup_Descriptor64_Vs (Image_Dsc, Image_Name'Address); - Setup_Descriptor64_Vs (Module_Dsc, Module_Name'Address); - Setup_Descriptor64_Vs (Routine_Dsc, Routine_Name'Address); - - for J in Traceback'Range loop - -- Initialize fields in case they are not written - - Record_Number := 0; - Line_Number := 0; - Image_Name.Curlen := 0; - Module_Name.Curlen := 0; - Routine_Name.Curlen := 0; - - -- Symbolize - - Param := (Length => K_Length, - T_Type => 0, - Version => K_Version, - Reserveda => 0, - Faulting_Pc => PC_For (Traceback (J)), - Faulting_Fp => 0, - Filename_Desc => Null_Address, - Library_Module_Desc => Null_Address, - Record_Number => Record_Number'Address, - Image_Desc => Image_Dsc'Address, - Module_Desc => Module_Dsc'Address, - Routine_Desc => Routine_Dsc'Address, - Listing_Lineno => Line_Number'Address, - Rel_Pc => Null_Address, - Image_Base_Addr => Null_Address, - Module_Base_Addr => Null_Address, - Malloc_Rtn => Null_Address, - Free_Rtn => Null_Address, - Symbolize_Flags => Null_Address, - Reserved0 => (0, 0), - Reserved1 => (0, 0), - Reserved2 => (0, 0)); - - Status := Symbolize (Param'Address); - - -- Check for success (marked by bit 0) - - if (Status rem 2) = 1 then - - -- Success - - if Line_Number = 0 then - - -- As GCC doesn't emit source file correlation, use record - -- number of line number is not set - - Line_Number := Record_Number; - end if; - - declare - First : constant Integer := Len + 1; - Last : Integer := First + 80 - 1; - Pos : Integer; - - Routine_Name_D : constant String := - Decode_Ada_Name - (Routine_Name.Buf - (1 .. Natural (Routine_Name.Curlen))); - - Lineno : constant String := - Unsigned_Longword'Image (Line_Number); - - begin - Res (First .. Last) := (others => ' '); - - Res (First .. First + Natural (Image_Name.Curlen) - 1) := - Image_Name.Buf (1 .. Natural (Image_Name.Curlen)); - - Res (First + 10 .. - First + 10 + Natural (Module_Name.Curlen) - 1) := - Module_Name.Buf (1 .. Natural (Module_Name.Curlen)); - - Res (First + 30 .. - First + 30 + Routine_Name_D'Length - 1) := - Routine_Name_D; - - -- If routine name doesn't fit 20 characters, output the line - -- number on next line at 50th position. - - if Routine_Name_D'Length > 20 then - Pos := First + 30 + Routine_Name_D'Length; - Res (Pos) := ASCII.LF; - Last := Pos + 80; - Res (Pos + 1 .. Last) := (others => ' '); - Pos := Pos + 51; - else - Pos := First + 50; - end if; - - Res (Pos .. Pos + Lineno'Length - 1) := Lineno; - - Res (Last) := ASCII.LF; - Len := Last; - end; - - -- Failure (bit 0 clear) - - else - Res (Len + 1 .. Len + 6) := "ERROR" & ASCII.LF; - Len := Len + 6; - end if; - end loop; - - System.Soft_Links.Unlock_Task.all; - return Res (1 .. Len); - end Symbolic_Traceback; - - function Symbolic_Traceback (E : Exception_Occurrence) return String is - begin - return Symbolic_Traceback (Tracebacks (E)); - end Symbolic_Traceback; - -end GNAT.Traceback.Symbolic; diff --git a/main/gcc/ada/g-trasym.adb b/main/gcc/ada/g-trasym.adb index a825f80b704..3fdfd1adad7 100644 --- a/main/gcc/ada/g-trasym.adb +++ b/main/gcc/ada/g-trasym.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -29,49 +29,8 @@ -- -- ------------------------------------------------------------------------------ --- This is the default implementation for platforms where the full capability --- is not supported. It returns tracebacks as lists of LF separated strings of --- the form "0x..." corresponding to the addresses. +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with System.Address_Image; - -package body GNAT.Traceback.Symbolic is - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is - begin - if Traceback'Length = 0 then - return ""; - - else - declare - Img : String := System.Address_Image (Traceback (Traceback'First)); - - Result : String (1 .. (Img'Length + 3) * Traceback'Length); - Last : Natural := 0; - - begin - for J in Traceback'Range loop - Img := System.Address_Image (Traceback (J)); - Result (Last + 1 .. Last + 2) := "0x"; - Last := Last + 2; - Result (Last + 1 .. Last + Img'Length) := Img; - Last := Last + Img'Length + 1; - Result (Last) := ASCII.LF; - end loop; - - return Result (1 .. Last); - end; - end if; - end Symbolic_Traceback; - - function Symbolic_Traceback (E : Exception_Occurrence) return String is - begin - return Symbolic_Traceback (Tracebacks (E)); - end Symbolic_Traceback; - -end GNAT.Traceback.Symbolic; +pragma No_Body; diff --git a/main/gcc/ada/gnat.ads b/main/gcc/ada/g-trasym.ads similarity index 87% copy from main/gcc/ada/gnat.ads copy to main/gcc/ada/g-trasym.ads index cfdfdc837eb..1d9b3f7ec21 100644 --- a/main/gcc/ada/gnat.ads +++ b/main/gcc/ada/g-trasym.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T -- +-- G N A T . T R A C E B A C K . S Y M B O L I C -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -29,9 +29,9 @@ -- -- ------------------------------------------------------------------------------ --- This is the parent package for a library of useful units provided with GNAT +-- Run-time symbolic traceback support -package GNAT is - pragma Pure; +-- See file s-trasym.ads for full documentation of the interface -end GNAT; +with System.Traceback.Symbolic; +package GNAT.Traceback.Symbolic renames System.Traceback.Symbolic; diff --git a/main/gcc/ada/g-wistsp.ads b/main/gcc/ada/g-wistsp.ads index 7fceb17d792..39f19a6717a 100644 --- a/main/gcc/ada/g-wistsp.ads +++ b/main/gcc/ada/g-wistsp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/g-zstspl.ads b/main/gcc/ada/g-zstspl.ads index f3af568115a..de87324b7a9 100644 --- a/main/gcc/ada/g-zstspl.ads +++ b/main/gcc/ada/g-zstspl.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/gcc-interface/Make-lang.in b/main/gcc/ada/gcc-interface/Make-lang.in index 321c0d68896..478272fac7b 100644 --- a/main/gcc/ada/gcc-interface/Make-lang.in +++ b/main/gcc/ada/gcc-interface/Make-lang.in @@ -89,7 +89,7 @@ ADA_FLAGS_TO_PASS = \ # List of Ada tools to build and install ADA_TOOLS=gnatbind gnatchop gnat gnatkr gnatlink gnatls gnatmake \ - gnatname gnatprep gnatxref gnatfind gnatclean gnatsym + gnatname gnatprep gnatxref gnatfind gnatclean # Say how to compile Ada programs. .SUFFIXES: .ada .adb .ads @@ -128,11 +128,12 @@ ada: gnat1$(exeext) gnatbind$(exeext) # Tell GNU Make to ignore these, if they exist. .PHONY: ada -CXX_LFLAGS = \ - -B../../../$(target_noncanonical)/libstdc++-v3/src/.libs \ - -B../../../$(target_noncanonical)/libstdc++-v3/libsupc++/.libs \ - -L../../../$(target_noncanonical)/libstdc++-v3/src/.libs \ - -L../../../$(target_noncanonical)/libstdc++-v3/libsupc++/.libs +# Compute the FLAGS to pass for gnattools, now linked with a C++ driver as +# we're linking against at least libcommon which contains C++ compiled code. +# We need to use the same driver to link as the one that was used to produce +# the objects, which depends on whether we're bootstrapping or not. The CXX +# variable conveys what we need for this, set to "g++" if not bootstrapping, +# ".../xg++" otherwise. # There are too many Ada sources to check against here. Let's # always force the recursive make. @@ -142,7 +143,7 @@ ifeq ($(build), $(host)) # tree. ADA_TOOLS_FLAGS_TO_PASS=\ CC="../../xgcc -B../../" \ - CXX="../../xg++ -B../../ $(CXX_LFLAGS)" \ + CXX="$(CXX)" \ $(COMMON_FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \ ADA_INCLUDES="-I- -I../rts" \ GNATMAKE="../../gnatmake" \ @@ -281,7 +282,6 @@ GNAT_ADA_OBJS = \ ada/exp_strm.o \ ada/exp_tss.o \ ada/exp_util.o \ - ada/exp_vfpt.o \ ada/expander.o \ ada/fmap.o \ ada/fname-uf.o \ @@ -415,7 +415,6 @@ GNAT_ADA_OBJS = \ ada/sem_smem.o \ ada/sem_type.o \ ada/sem_util.o \ - ada/sem_vfpt.o \ ada/sem_warn.o \ ada/set_targ.o \ ada/sinfo-cn.o \ @@ -655,26 +654,7 @@ ada.tags: force # Generate documentation. -ada/doctools/xgnatugn$(build_exeext): ada/xgnatugn.adb - -$(MKDIR) ada/doctools - $(CP) $^ ada/doctools - cd ada/doctools && gnatmake -q xgnatugn - -# Note that doc/gnat_ugn.texi and doc/projects.texi do not depend on -# xgnatugn being built so we can distribute a pregenerated doc/gnat_ugn.info - -doc/gnat_ugn.texi: $(srcdir)/ada/gnat_ugn.texi $(srcdir)/ada/ug_words \ - doc/projects.texi $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi - $(MAKE) ada/doctools/xgnatugn$(build_exeext) - ada/doctools/xgnatugn unw $(srcdir)/ada/gnat_ugn.texi \ - $(srcdir)/ada/ug_words doc/gnat_ugn.texi - -doc/projects.texi: $(srcdir)/ada/projects.texi - $(MAKE) ada/doctools/xgnatugn$(build_exeext) - ada/doctools/xgnatugn unw $(srcdir)/ada/projects.texi \ - $(srcdir)/ada/ug_words doc/projects.texi - -doc/gnat_ugn.info: doc/gnat_ugn.texi \ +doc/gnat_ugn.info: ada/gnat_ugn.texi ada/projects.texi \ $(gcc_docdir)/include/fdl.texi $(gcc_docdir)/include/gcc-common.texi \ gcc-vers.texi if [ x$(BUILD_INFO) = xinfo ]; then \ @@ -699,8 +679,7 @@ doc/gnat-style.info: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi \ -I$(srcdir)/ada -o $@ $<; \ else true; fi -ADA_INFOFILES = doc/gnat_ugn.info doc/gnat_ugn.texi \ - doc/gnat_rm.info doc/gnat-style.info +ADA_INFOFILES = doc/gnat_ugn.info doc/gnat_rm.info doc/gnat-style.info ada.info: $(ADA_INFOFILES) @@ -733,7 +712,8 @@ ada.html: ada.install-html: -doc/gnat_ugn.dvi: doc/gnat_ugn.texi $(gcc_docdir)/include/fdl.texi \ +doc/gnat_ugn.dvi: ada/gnat_ugn.texi ada/projects.texi \ + $(gcc_docdir)/include/fdl.texi \ $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< @@ -744,7 +724,8 @@ doc/gnat_rm.dvi: ada/gnat_rm.texi $(gcc_docdir)/include/fdl.texi \ doc/gnat-style.dvi: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi $(TEXI2DVI) -c -I $(abs_docdir)/include -o $@ $< -doc/gnat_ugn.pdf: doc/gnat_ugn.texi $(gcc_docdir)/include/fdl.texi \ +doc/gnat_ugn.pdf: ada/gnat_ugn.texi ada/projects.texi \ + $(gcc_docdir)/include/fdl.texi \ $(gcc_docdir)/include/gcc-common.texi gcc-vers.texi $(TEXI2PDF) -c -I $(abs_docdir)/include -o $@ $< @@ -764,8 +745,7 @@ doc/gnat-style.pdf: ada/gnat-style.texi $(gcc_docdir)/include/fdl.texi # or from the --target option if the former is not specified. # Do the same for the rest of the Ada tools (gnatchop, gnat, gnatkr, # gnatlink, gnatls, gnatmake, gnatname, gnatprep, gnatxref, gnatfind, -# gnatclean, gnatsym). -# gnatsym is only built on some platforms, including VMS. +# gnatclean). # gnatdll is only used on Windows. # vxaddr2line is only used for cross VxWorks ports (it calls the underlying # cross addr2line). @@ -841,7 +821,6 @@ ada.distclean: -$(RM) gnatfind$(exeext) -$(RM) gnatxref$(exeext) -$(RM) gnatclean$(exeext) - -$(RM) gnatsym$(exeext) -$(RM) ada/rts/* -$(RMDIR) ada/rts -$(RM) ada/tools/* diff --git a/main/gcc/ada/gcc-interface/Makefile.in b/main/gcc/ada/gcc-interface/Makefile.in index 5c36962ef3b..03df9321765 100644 --- a/main/gcc/ada/gcc-interface/Makefile.in +++ b/main/gcc/ada/gcc-interface/Makefile.in @@ -1,5 +1,5 @@ # Makefile for GNU Ada Compiler (GNAT). -# Copyright (C) 1994-2013 Free Software Foundation, Inc. +# Copyright (C) 1994-2014 Free Software Foundation, Inc. #This file is part of GCC. @@ -106,6 +106,7 @@ GNATBIND_FLAGS = -static -x ADA_CFLAGS = ADAFLAGS = -W -Wall -gnatpg -gnata FORCE_DEBUG_ADAFLAGS = -g +NO_INLINE_ADAFLAGS = -fno-inline NO_SIBLING_ADAFLAGS = -fno-optimize-sibling-calls NO_REORDER_ADAFLAGS = -fno-toplevel-reorder GNATLIBFLAGS = -W -Wall -gnatpg -nostdinc @@ -450,10 +451,22 @@ LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ad # Additionnal object files from C source to be added to libgnat. EXTRA_LIBGNAT_OBJS= -# Additionnal C source file to be added to libgnat without corresponding object -# file (included files). + +# Additionnal C source files to be added to libgnat without corresponding +# object file (#included files). This should include at least the GNAT +# specific header files required to rebuild the runtime library from sources. EXTRA_LIBGNAT_SRCS= +# GCC spec files to be installed in $(libsubdir), so --specs= +# 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. +# +GCC_SPEC_FILES= + # $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT. # $(strip STRING) removes leading and trailing spaces from STRING. # If what's left is null then it's a match. @@ -502,7 +515,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,$(target_cpu) $(target_vendor) $(target_os))),) +ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),) ifeq ($(strip $(filter-out e500%, $(target_alias))),) ARCH_STR=e500 @@ -563,6 +576,9 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(target_cpu) $(target_vendor) $ s-vxwext.adb s-oscons-tmplt.s +OSCONS_CC=$(subst ./xgcc,../../xgcc,$(subst -B./, -B../../,$(GCC_FOR_TARGET))) -else -# GCC_FOR_TARGET has paths relative to the gcc directory, so we need to adjust -# for running it from $(RTSDIR) -OSCONS_CC=`echo "$(GCC_FOR_TARGET)" \ - | sed -e 's^\./xgcc^../../xgcc^' -e 's^-B./^-B../../^'` -OSCONS_CPP=$(OSCONS_CC) $(GNATLIBCFLAGS) -E -C \ - -DTARGET=\"$(target)\" $(fsrcpfx)ada/s-oscons-tmplt.c > s-oscons-tmplt.i -OSCONS_EXTRACT=$(OSCONS_CC) $(GNATLIBCFLAGS) -S s-oscons-tmplt.i -endif +# The main ada source directory must be on the include path for #include "..." +# because s-oscons-tmplt.c requires adaint.h, gsocket.h, and any file included +# by these headers. However note that we must use -iquote, not -I, so that +# ada/types.h does not conflict with a same-named system header (VxWorks +# has a header). + +OSCONS_CPP=$(OSCONS_CC) $(GNATLIBCFLAGS) $(GNATLIBCFLAGS_FOR_C) -E -C \ + -DTARGET=\"$(target)\" -iquote $(fsrcpfx)ada $(fsrcpfx)ada/s-oscons-tmplt.c > s-oscons-tmplt.i +OSCONS_EXTRACT=$(OSCONS_CC) -S s-oscons-tmplt.i + +# Note: if you need to build with a non-GNU compiler, you could adapt the +# following definitions (written for VMS DEC-C) +#OSCONS_CPP=../../../$(DECC) -E /comment=as_is -DNATIVE \ +# -DTARGET='""$(target)""' -I$(OSCONS_SRCDIR) s-oscons-tmplt.c +# +#OSCONS_EXTRACT=../../../$(DECC) -DNATIVE \ +# -DTARGET='""$(target)""' -I$(OSCONS_SRCDIR) s-oscons-tmplt.c ; \ +# ld -o s-oscons-tmplt.exe s-oscons-tmplt.obj; \ +# ./s-oscons-tmplt.exe > s-oscons-tmplt.s ./bldtools/oscons/xoscons: xoscons.adb xutil.ads xutil.adb -$(MKDIR) ./bldtools/oscons @@ -2759,13 +2725,8 @@ $(RTSDIR)/s-oscons.ads: ../stamp-gnatlib1-$(RTSDIR) s-oscons-tmplt.c gsocket.h . $(OSCONS_EXTRACT) ; \ ../bldtools/oscons/xoscons s-oscons) -# Don't use semicolon separated shell commands that involve list expansions. -# The semicolon triggers a call to DCL on VMS and DCL can't handle command -# line lengths in excess of 256 characters. -# Example: cd $(RTSDIR); ar rc libfoo.a $(LONG_LIST_OF_OBJS) -# is guaranteed to overflow the buffer. - gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR) $(RTSDIR)/s-oscons.ads + test -f $(RTSDIR)/s-oscons.ads || exit 1 # C files $(MAKE) -C $(RTSDIR) \ CC="`echo \"$(GCC_FOR_TARGET)\" \ @@ -2925,35 +2886,6 @@ gnatlib-shared-darwin: cd $(RTSDIR); dsymutil libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) cd $(RTSDIR); dsymutil libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) -gnatlib-shared-vms: - $(MAKE) $(FLAGS_TO_PASS) \ - GNATLIBFLAGS="$(GNATLIBFLAGS)" \ - GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \ - GNATLIBCFLAGS_FOR_C="$(GNATLIBCFLAGS_FOR_C)" \ - MULTISUBDIR="$(MULTISUBDIR)" \ - THREAD_KIND="$(THREAD_KIND)" \ - gnatlib - $(RM) $(RTSDIR)/libgna*$(soext) - cd $(RTSDIR) && \ - ../../gnatsym -s SYMVEC_$$$$.opt \ - $(LIBGNAT_OBJS) $(GNATRTL_NONTASKING_OBJS) && \ - ../../xgcc -g -B../../ -shared -shared-libgcc \ - -o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) libgnat.a \ - sys\$$library:trace.exe \ - --for-linker=/noinform \ - --for-linker=SYMVEC_$$$$.opt \ - --for-linker=gsmatch=equal,$(GSMATCH_VERSION) - cd $(RTSDIR) && \ - ../../gnatsym -s SYMVEC_$$$$.opt \ - $(GNATRTL_TASKING_OBJS) && \ - ../../xgcc -g -B../../ -shared -shared-libgcc \ - -o libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \ - libgnarl.a libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \ - sys\$$library:trace.exe \ - --for-linker=/noinform \ - --for-linker=SYMVEC_$$$$.opt \ - --for-linker=gsmatch=equal,$(GSMATCH_VERSION) - gnatlib-shared: $(MAKE) $(FLAGS_TO_PASS) \ GNATLIBFLAGS="$(GNATLIBFLAGS)" \ @@ -3033,27 +2965,19 @@ ADA_RTL_OBJ_DIR = $(libsubdir)/adalib # force no sibling call optimization on s-traceb.o so the number of stack # frames to be skipped when computing a call chain is not modified by -# optimization. +# optimization. We don't want inlining, either. s-traceb.o : s-traceb.adb s-traceb.ads - $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \ + $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(NO_INLINE_ADAFLAGS) \ $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) -# force debugging information on s-tasdeb.o so that it is always -# possible to set conditional breakpoints on tasks. +# compile s-tasdeb.o without optimization and with debug info so that it is +# always possible to set conditional breakpoints on tasks. s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \ $< $(OUTPUT_OPTION) -# force debugging information on s-vaflop.o so that it is always -# possible to call the VAX float debug print routines. -# force at least -O so that the inline assembly works. - -s-vaflop.o : s-vaflop.adb s-vaflop.ads - $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) - # force no function reordering on a-except.o because of the exclusion bounds # mechanism (see the source file for more detailed information). # force debugging information on a-except.o so that it is always @@ -3088,7 +3012,7 @@ a-tags.o : a-tags.adb a-tags.ads # need to keep the frame pointer in this file to pop the stack properly on # some targets. -tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c tb-gcc.c +tracebak.o : tracebak.c tb-gcc.c $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \ $(INCLUDES) -fno-omit-frame-pointer $< $(OUTPUT_OPTION) @@ -3107,8 +3031,7 @@ 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-armvxw.o : sigtramp-armvxw.c sigtramp.h -sigtramp-ppcvxw.o : sigtramp-ppcvxw.c sigtramp.h +sigtramp-vxworks.o : sigtramp-vxworks.c sigtramp.h terminals.o : terminals.c vx_stack_info.o : vx_stack_info.c diff --git a/main/gcc/ada/gcc-interface/ada-tree.h b/main/gcc/ada/gcc-interface/ada-tree.h index d43eefa004e..ba5765d0dba 100644 --- a/main/gcc/ada/gcc-interface/ada-tree.h +++ b/main/gcc/ada/gcc-interface/ada-tree.h @@ -120,11 +120,6 @@ do { \ || TREE_CODE (NODE) == ENUMERAL_TYPE) \ && TYPE_BY_REFERENCE_P (NODE)) -/* For INTEGER_TYPE, nonzero if this really represents a VAX - floating-point type. */ -#define TYPE_VAX_FLOATING_POINT_P(NODE) \ - TYPE_LANG_FLAG_3 (INTEGER_TYPE_CHECK (NODE)) - /* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, nonzero if this is the type for an object whose type includes its template in addition to its value (only true for RECORD_TYPE). */ @@ -257,7 +252,11 @@ do { \ bound but they must nevertheless be valid in the GCC type system, otherwise the optimizer can pretend that they simply don't exist. Therefore they must be within the range of values allowed by the lower bound in the GCC - sense, hence the GCC lower bound be set to that of the base type. */ + sense, hence the GCC lower bound be set to that of the base type. + + This lower bound is translated directly without the adjustments that may + be required for type compatibility, so it will generally be necessary to + convert it to the base type of the numerical type before using it. */ #define TYPE_RM_MIN_VALUE(NODE) TYPE_RM_VALUE ((NODE), 1) #define SET_TYPE_RM_MIN_VALUE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 1, (X)) @@ -269,7 +268,11 @@ do { \ bound but they must nevertheless be valid in the GCC type system, otherwise the optimizer can pretend that they simply don't exist. Therefore they must be within the range of values allowed by the upper bound in the GCC - sense, hence the GCC upper bound be set to that of the base type. */ + sense, hence the GCC upper bound be set to that of the base type. + + This upper bound is translated directly without the adjustments that may + be required for type compatibility, so it will generally be necessary to + convert it to the base type of the numerical type before using it. */ #define TYPE_RM_MAX_VALUE(NODE) TYPE_RM_VALUE ((NODE), 2) #define SET_TYPE_RM_MAX_VALUE(NODE, X) SET_TYPE_RM_VALUE ((NODE), 2, (X)) @@ -294,15 +297,18 @@ do { \ #define SET_TYPE_MODULUS(NODE, X) \ SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) -/* For an INTEGER_TYPE with TYPE_VAX_FLOATING_POINT_P, this is the - Digits_Value. */ -#define TYPE_DIGITS_VALUE(NODE) \ - GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) -#define SET_TYPE_DIGITS_VALUE(NODE, X) \ - SET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE), X) - /* For an INTEGER_TYPE that is the TYPE_DOMAIN of some ARRAY_TYPE, this is - the type corresponding to the Ada index type. */ + the type corresponding to the Ada index type. It is necessary to keep + these 2 views for every array type because the TYPE_DOMAIN is subject + to strong constraints in GENERIC: it must be a subtype of SIZETYPE and + may not be superflat, i.e. the upper bound must always be larger or + equal to the lower bound minus 1 (i.e. the canonical length formula + must always yield a non-negative number), which means that at least + one of the bounds may need to be a conditional expression. There are + no such constraints on the TYPE_INDEX_TYPE because gigi is prepared to + deal with the superflat case; moreover the TYPE_INDEX_TYPE is used as + the index type for the debug info and, therefore, needs to be as close + as possible to the source index type. */ #define TYPE_INDEX_TYPE(NODE) \ GET_TYPE_LANG_SPECIFIC (INTEGER_TYPE_CHECK (NODE)) #define SET_TYPE_INDEX_TYPE(NODE, X) \ @@ -388,9 +394,6 @@ do { \ is readonly. */ #define DECL_POINTS_TO_READONLY_P(NODE) DECL_LANG_FLAG_4 (NODE) -/* Nonzero in a PARM_DECL if we are to pass by descriptor. */ -#define DECL_BY_DESCRIPTOR_P(NODE) DECL_LANG_FLAG_5 (PARM_DECL_CHECK (NODE)) - /* Nonzero in a VAR_DECL if it is a pointer renaming a global object. */ #define DECL_RENAMING_GLOBAL_P(NODE) DECL_LANG_FLAG_5 (VAR_DECL_CHECK (NODE)) @@ -448,19 +451,6 @@ do { \ #define SET_DECL_PARALLEL_TYPE(NODE, X) \ SET_DECL_LANG_SPECIFIC (TYPE_DECL_CHECK (NODE), X) -/* In a FUNCTION_DECL, points to the stub associated with the function - if any, otherwise 0. */ -#define DECL_FUNCTION_STUB(NODE) \ - GET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE)) -#define SET_DECL_FUNCTION_STUB(NODE, X) \ - SET_DECL_LANG_SPECIFIC (FUNCTION_DECL_CHECK (NODE), X) - -/* In a PARM_DECL, points to the alternate TREE_TYPE. */ -#define DECL_PARM_ALT_TYPE(NODE) \ - GET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE)) -#define SET_DECL_PARM_ALT_TYPE(NODE, X) \ - SET_DECL_LANG_SPECIFIC (PARM_DECL_CHECK (NODE), X) - /* Flags added to ref nodes. */ diff --git a/main/gcc/ada/gcc-interface/decl.c b/main/gcc/ada/gcc-interface/decl.c index 6ece8d87b30..8e3db64392e 100644 --- a/main/gcc/ada/gcc-interface/decl.c +++ b/main/gcc/ada/gcc-interface/decl.c @@ -172,6 +172,7 @@ static tree get_rep_part (tree); static tree create_variant_part_from (tree, vec , tree, tree, vec ); static void copy_and_substitute_in_size (tree, tree, vec ); +static void add_parallel_type_for_packed_array (tree, Entity_Id); /* The relevant constituents of a subprogram binding to a GCC builtin. Used to pass around calls performing profile compatibility checks. */ @@ -349,9 +350,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) || Is_Public (gnat_entity)); /* Get the name of the entity and set up the line number and filename of - the original definition for use in any decl we make. */ + the original definition for use in any decl we make. Make sure we do not + inherit another source location. */ gnu_entity_name = get_entity_name (gnat_entity); - Sloc_to_locus (Sloc (gnat_entity), &input_location); + if (Sloc (gnat_entity) != No_Location + && !renaming_from_generic_instantiation_p (gnat_entity)) + Sloc_to_locus (Sloc (gnat_entity), &input_location); /* For cases when we are not defining (i.e., we are referencing from another compilation unit) public entities, show we are at global level @@ -485,15 +489,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) goto object; case E_Exception: - /* We used to special case VMS exceptions here to directly map them to - their associated condition code. Since this code had to be masked - dynamically to strip off the severity bits, this caused trouble in - the GCC/ZCX case because the "type" pointers we store in the tables - have to be static. We now don't special case here anymore, and let - the regular processing take place, which leaves us with a regular - exception data object for VMS exceptions too. The condition code - mapping is taken care of by the front end and the bitmasking by the - run-time library. */ goto object; case E_Component: @@ -502,33 +497,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* The GNAT record where the component was defined. */ Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity)); - /* If the entity is an inherited component (in the case of extended - tagged record types), just return the original entity, which must - be a FIELD_DECL. Likewise for discriminants. If the entity is a - non-girder discriminant (in the case of derived untagged record - types), return the stored discriminant it renames. */ - if (Present (Original_Record_Component (gnat_entity)) - && Original_Record_Component (gnat_entity) != gnat_entity) + /* If the entity is a discriminant of an extended tagged type used to + rename a discriminant of the parent type, return the latter. */ + if (Is_Tagged_Type (gnat_record) + && Present (Corresponding_Discriminant (gnat_entity))) { gnu_decl - = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), + = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), gnu_expr, definition); saved = true; break; } - /* If this is a discriminant of an extended tagged type used to rename - a discriminant of the parent type, return the latter. */ - else if (Present (Corresponding_Discriminant (gnat_entity))) + /* If the entity is an inherited component (in the case of extended + tagged record types), just return the original entity, which must + be a FIELD_DECL. Likewise for discriminants. If the entity is a + non-girder discriminant (in the case of derived untagged record + types), return the stored discriminant it renames. */ + else if (Present (Original_Record_Component (gnat_entity)) + && Original_Record_Component (gnat_entity) != gnat_entity) { - /* If the derived type is untagged, then this is a non-girder - discriminant and its Original_Record_Component must point to - the stored discriminant it renames (i.e. we should have taken - the previous branch). */ - gcc_assert (Is_Tagged_Type (gnat_record)); - gnu_decl - = gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity), + = gnat_to_gnu_entity (Original_Record_Component (gnat_entity), gnu_expr, definition); saved = true; break; @@ -1428,16 +1418,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)) gnu_expr = convert (gnu_type, gnu_expr); - /* If this name is external or there was a name specified, use it, - unless this is a VMS exception object since this would conflict - with the symbol we need to export in addition. Don't use the - Interface_Name if there is an address clause (see CD30005). */ - if (!Is_VMS_Exception (gnat_entity) - && ((Present (Interface_Name (gnat_entity)) - && No (Address_Clause (gnat_entity))) - || (Is_Public (gnat_entity) - && (!Is_Imported (gnat_entity) - || Is_Exported (gnat_entity))))) + /* If this name is external or a name was specified, use it, but don't + use the Interface_Name with an address clause (see cd30005). */ + if ((Present (Interface_Name (gnat_entity)) + && No (Address_Clause (gnat_entity))) + || (Is_Public (gnat_entity) + && (!Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))) gnu_ext_name = create_concat_name (gnat_entity, NULL); /* If this is an aggregate constant initialized to a constant, force it @@ -1753,20 +1739,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity)); SET_TYPE_RM_MIN_VALUE - (gnu_type, - convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, get_identifier ("L"), - definition, true, - Needs_Debug_Info (gnat_entity)))); + (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, true, + Needs_Debug_Info (gnat_entity))); SET_TYPE_RM_MAX_VALUE - (gnu_type, - convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, get_identifier ("U"), - definition, true, - Needs_Debug_Info (gnat_entity)))); + (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, true, + Needs_Debug_Info (gnat_entity))); TYPE_BIASED_REPRESENTATION_P (gnu_type) = Has_Biased_Representation (gnat_entity); @@ -1789,12 +1771,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) = create_type_stub_decl (gnu_entity_name, gnu_type); /* For a packed array, make the original array type a parallel type. */ - if (debug_info_p - && Is_Packed_Array_Impl_Type (gnat_entity) - && present_gnu_tree (Original_Array_Type (gnat_entity))) - add_parallel_type (gnu_type, - gnat_to_gnu_type - (Original_Array_Type (gnat_entity))); + if (debug_info_p && Is_Packed_Array_Impl_Type (gnat_entity)) + add_parallel_type_for_packed_array (gnu_type, gnat_entity); discrete_type: @@ -1866,10 +1844,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (debug_info_p) { /* Make the original array type a parallel type. */ - if (present_gnu_tree (Original_Array_Type (gnat_entity))) - add_parallel_type (gnu_type, - gnat_to_gnu_type - (Original_Array_Type (gnat_entity))); + add_parallel_type_for_packed_array (gnu_type, gnat_entity); rest_of_record_type_compilation (gnu_type); } @@ -1920,18 +1895,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) break; case E_Floating_Point_Type: - /* If this is a VAX floating-point type, use an integer of the proper - size. All the operations will be handled with ASM statements. */ - if (Vax_Float (gnat_entity)) - { - gnu_type = make_signed_type (esize); - TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1; - SET_TYPE_DIGITS_VALUE (gnu_type, - UI_To_gnu (Digits_Value (gnat_entity), - sizetype)); - break; - } - /* The type of the Low and High bounds can be our type if this is a type from Standard, so set them at the end of the function. */ gnu_type = make_node (REAL_TYPE); @@ -1940,12 +1903,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) break; case E_Floating_Point_Subtype: - if (Vax_Float (gnat_entity)) - { - gnu_type = gnat_to_gnu_type (Etype (gnat_entity)); - break; - } - /* See the E_Signed_Integer_Subtype case for the rationale. */ if (!definition && Present (Ancestor_Subtype (gnat_entity)) @@ -1964,20 +1921,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) layout_type (gnu_type); SET_TYPE_RM_MIN_VALUE - (gnu_type, - convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_Low_Bound (gnat_entity), - gnat_entity, get_identifier ("L"), - definition, true, - Needs_Debug_Info (gnat_entity)))); + (gnu_type, elaborate_expression (Type_Low_Bound (gnat_entity), + gnat_entity, get_identifier ("L"), + definition, true, + Needs_Debug_Info (gnat_entity))); SET_TYPE_RM_MAX_VALUE - (gnu_type, - convert (TREE_TYPE (gnu_type), - elaborate_expression (Type_High_Bound (gnat_entity), - gnat_entity, get_identifier ("U"), - definition, true, - Needs_Debug_Info (gnat_entity)))); + (gnu_type, elaborate_expression (Type_High_Bound (gnat_entity), + gnat_entity, get_identifier ("U"), + definition, true, + Needs_Debug_Info (gnat_entity))); /* Inherit our alias set from what we're a subtype of, as for integer subtypes. */ @@ -1988,7 +1941,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) maybe_present = true; break; - /* Array and String Types and Subtypes + /* Array Types and Subtypes Unconstrained array types are represented by E_Array_Type and constrained array types are represented by E_Array_Subtype. There @@ -2001,7 +1954,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) Number_Dimensions Number of dimensions (an int). First_Index Type of first index. */ - case E_String_Type: case E_Array_Type: { const bool convention_fortran_p @@ -2227,7 +2179,7 @@ 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 (Reverse_Storage_Order (gnat_entity)) + if (Reverse_Storage_Order (gnat_entity) && !GNAT_Mode) sorry ("non-default Scalar_Storage_Order"); TYPE_MULTI_ARRAY_P (tem) = (index > 0); if (array_type_has_nonaliased_component (tem, gnat_entity)) @@ -2312,7 +2264,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } break; - case E_String_Subtype: case E_Array_Subtype: /* This is the actual data type for array variables. Multidimensional @@ -2354,14 +2305,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnat_base_index = Next_Index (gnat_base_index)) { tree gnu_index_type = get_unpadded_type (Etype (gnat_index)); - tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type); - tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type); + tree gnu_index_base_type = get_base_type (gnu_index_type); + tree gnu_orig_min + = convert (gnu_index_base_type, + TYPE_MIN_VALUE (gnu_index_type)); + tree gnu_orig_max + = convert (gnu_index_base_type, + TYPE_MAX_VALUE (gnu_index_type)); tree gnu_min = convert (sizetype, gnu_orig_min); tree gnu_max = convert (sizetype, gnu_orig_max); tree gnu_base_index_type = get_unpadded_type (Etype (gnat_base_index)); - tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type); - tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type); + tree gnu_base_index_base_type + = get_base_type (gnu_base_index_type); + tree gnu_base_orig_min + = convert (gnu_base_index_base_type, + TYPE_MIN_VALUE (gnu_base_index_type)); + tree gnu_base_orig_max + = convert (gnu_base_index_base_type, + TYPE_MAX_VALUE (gnu_base_index_type)); tree gnu_high; /* See if the base array type is already flat. If it is, we @@ -2674,11 +2636,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) isn't artificial to make sure it is kept in the debug info. */ if (debug_info_p) { - if (Is_Packed_Array_Impl_Type (gnat_entity) - && present_gnu_tree (Original_Array_Type (gnat_entity))) - add_parallel_type (gnu_type, - gnat_to_gnu_type - (Original_Array_Type (gnat_entity))); + if (Is_Packed_Array_Impl_Type (gnat_entity)) + add_parallel_type_for_packed_array (gnu_type, gnat_entity); else { tree gnu_base_decl @@ -2952,7 +2911,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) gnu_type = make_node (tree_code_for_record_type (gnat_entity)); TYPE_NAME (gnu_type) = gnu_entity_name; TYPE_PACKED (gnu_type) = (packed != 0) || has_rep; - if (Reverse_Storage_Order (gnat_entity)) + if (Reverse_Storage_Order (gnat_entity) && !GNAT_Mode) sorry ("non-default Scalar_Storage_Order"); process_attributes (&gnu_type, &attr_list, true, gnat_entity); @@ -4121,8 +4080,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) 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; - /* Likewise for the stub associated with an exported procedure. */ - tree gnu_stub_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 @@ -4138,14 +4095,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* 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; - /* For the stub associated with an exported procedure. */ - tree gnu_stub_type = NULL_TREE, gnu_stub_name = NULL_TREE; tree gnu_ext_name = create_concat_name (gnat_entity, NULL); Entity_Id gnat_param; enum inline_status_t inline_status = Has_Pragma_No_Inline (gnat_entity) ? is_suppressed - : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled); + : Has_Pragma_Inline_Always (gnat_entity) + ? is_required + : (Is_Inlined (gnat_entity) ? is_enabled : is_disabled); bool public_flag = Is_Public (gnat_entity) || imported_p; bool extern_flag = (Is_Public (gnat_entity) && !definition) || imported_p; @@ -4165,7 +4122,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) bool return_by_direct_ref_p = false; bool return_by_invisi_ref_p = false; bool return_unconstrained_p = false; - bool has_stub = false; int parmnum; /* A parameter may refer to this type, so defer completion of any @@ -4369,15 +4325,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* 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) + || mech == By_Copy + || mech == By_Reference) ; - else if (By_Descriptor_Last <= mech && mech <= By_Descriptor) - mech = By_Descriptor; - - else if (By_Short_Descriptor_Last <= mech && - mech <= By_Short_Descriptor) - mech = By_Short_Descriptor; - else if (mech > 0) { if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE @@ -4435,26 +4385,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (gnu_param) { - /* If it's an exported subprogram, we build a parameter list - in parallel, in case we need to emit a stub for it. */ - if (Is_Exported (gnat_entity)) - { - gnu_stub_param_list - = chainon (gnu_param, gnu_stub_param_list); - /* Change By_Descriptor parameter to By_Reference for - the internal version of an exported subprogram. */ - if (mech == By_Descriptor || mech == By_Short_Descriptor) - { - gnu_param - = gnat_to_gnu_param (gnat_param, By_Reference, - gnat_entity, false, - ©_in_copy_out); - has_stub = true; - } - else - gnu_param = copy_node (gnu_param); - } - gnu_param_list = chainon (gnu_param, gnu_param_list); Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param)); @@ -4589,8 +4519,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) /* The lists have been built in reverse. */ gnu_param_list = nreverse (gnu_param_list); - if (has_stub) - gnu_stub_param_list = nreverse (gnu_stub_param_list); gnu_cico_list = nreverse (gnu_cico_list); if (kind == E_Function) @@ -4604,13 +4532,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) return_by_direct_ref_p, return_by_invisi_ref_p); - if (has_stub) - gnu_stub_type - = create_subprog_type (gnu_return_type, gnu_stub_param_list, - gnu_cico_list, return_unconstrained_p, - return_by_direct_ref_p, - return_by_invisi_ref_p); - /* A subprogram (something that doesn't return anything) shouldn't be considered const since there would be no reason for such a subprogram. Note that procedures with Out (or In Out) parameters @@ -4625,9 +4546,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) | (volatile_flag ? TYPE_QUAL_VOLATILE : 0); gnu_type = change_qualified_type (gnu_type, quals); - - if (has_stub) - gnu_stub_type = change_qualified_type (gnu_stub_type, quals); } /* If we have a builtin decl for that function, use it. Check if the @@ -4700,29 +4618,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) } else { - if (has_stub) - { - gnu_stub_name = gnu_ext_name; - gnu_ext_name = create_concat_name (gnat_entity, "internal"); - public_flag = false; - artificial_flag = true; - } - gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type, gnu_param_list, inline_status, public_flag, extern_flag, artificial_flag, attr_list, gnat_entity); - if (has_stub) - { - tree gnu_stub_decl - = create_subprog_decl (gnu_entity_name, gnu_stub_name, - gnu_stub_type, gnu_stub_param_list, - inline_status, true, extern_flag, - false, attr_list, gnat_entity); - SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl); - } - /* This is unrelated to the stub built right above. */ DECL_STUBBED_P (gnu_decl) = Convention (gnat_entity) == Convention_Stubbed; @@ -4749,7 +4649,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) ? Non_Limited_View (gnat_entity) : Present (Full_View (gnat_entity)) ? Full_View (gnat_entity) - : Underlying_Full_View (gnat_entity); + : IN (kind, Private_Kind) + ? Underlying_Full_View (gnat_entity) + : 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, @@ -5177,8 +5079,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) The language rules ensure the parent type is already frozen here. */ if (Is_Derived_Type (gnat_entity) && !type_annotate_only) { - tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity)); - relate_alias_sets (gnu_type, gnu_parent_type, + Entity_Id gnat_parent_type = Underlying_Type (Etype (gnat_entity)); + /* For packed array subtypes, the implementation type is used. */ + if (kind == E_Array_Subtype + && Present (Packed_Array_Impl_Type (gnat_parent_type))) + gnat_parent_type = Packed_Array_Impl_Type (gnat_parent_type); + relate_alias_sets (gnu_type, gnat_to_gnu_type (gnat_parent_type), Is_Composite_Type (gnat_entity) ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET); } @@ -5278,10 +5184,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) if (!saved) save_gnu_tree (gnat_entity, gnu_decl, false); + /* Now we are sure gnat_entity has a corresponding ..._DECL node, + eliminate as many deferred computations as possible. */ + process_deferred_decl_context (false); + /* If this is an enumeration or floating-point type, we were not able to set the bounds since they refer to the type. These are always static. */ if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity))) - || (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity))) + || (kind == E_Floating_Point_Type)) { tree gnu_scalar_type = gnu_type; tree gnu_low_bound, gnu_high_bound; @@ -5666,7 +5576,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, { tree gnu_param_name = get_entity_name (gnat_param); tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); - tree gnu_param_type_alt = NULL_TREE; 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); @@ -5717,31 +5626,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, && Is_Descendent_Of_Address (Etype (gnat_param))) gnu_param_type = ptr_void_type_node; - /* VMS descriptors are themselves passed by reference. */ - if (mech == By_Short_Descriptor || - (mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !flag_vms_malloc64)) - gnu_param_type - = build_pointer_type (build_vms_descriptor32 (gnu_param_type, - Mechanism (gnat_param), - gnat_subprog)); - else if (mech == By_Descriptor) - { - /* Build both a 32-bit and 64-bit descriptor, one of which will be - chosen in fill_vms_descriptor. */ - gnu_param_type_alt - = build_pointer_type (build_vms_descriptor32 (gnu_param_type, - Mechanism (gnat_param), - gnat_subprog)); - gnu_param_type - = build_pointer_type (build_vms_descriptor (gnu_param_type, - Mechanism (gnat_param), - gnat_subprog)); - } - /* Arrays are passed as pointers to element type for foreign conventions. */ - else if (foreign - && mech != By_Copy - && TREE_CODE (gnu_param_type) == ARRAY_TYPE) + if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE) { /* Strip off any multi-dimensional entries, then strip off the last array to get the component type. */ @@ -5824,9 +5710,7 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, if (Ekind (gnat_param) == E_Out_Parameter && !by_ref && (by_return - || (mech != By_Descriptor - && mech != By_Short_Descriptor - && !POINTER_TYPE_P (gnu_param_type) + || (!POINTER_TYPE_P (gnu_param_type) && !AGGREGATE_TYPE_P (gnu_param_type) && !Has_Default_Aspect (Etype (gnat_param)))) && !(Is_Array_Type (Etype (gnat_param)) @@ -5838,16 +5722,10 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, 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_BY_DESCRIPTOR_P (gnu_param) - = (mech == By_Descriptor || mech == By_Short_Descriptor); 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); - /* Save the alternate descriptor type, if any. */ - if (gnu_param_type_alt) - SET_DECL_PARM_ALT_TYPE (gnu_param, gnu_param_type_alt); - /* If no Mechanism was specified, indicate what we're using, then back-annotate it. */ if (mech == Default) @@ -6304,13 +6182,30 @@ elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name, /* Now create it, possibly only for debugging purposes. */ if (use_variable || need_debug) { + /* The following variable creation can happen when processing the body of + subprograms that are defined out of the extended main unit and + inlined. In this case, we are not at the global scope, and thus the + new variable must not be tagged "external", as we used to do here as + long as definition == 0. */ + const bool external_flag = !definition && expr_global_p; tree gnu_decl = create_var_decl_1 (create_concat_name (gnat_entity, IDENTIFIER_POINTER (gnu_name)), NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p, - !definition, expr_global_p, !need_debug, NULL, gnat_entity); - - if (use_variable) + external_flag, expr_global_p, !need_debug, NULL, gnat_entity); + + DECL_ARTIFICIAL (gnu_decl) = 1; + + /* Using this variable at debug time (if need_debug is true) requires a + proper location. The back-end will compute a location for this + variable only if the variable is used by the generated code. + Returning the variable ensures the caller will use it in generated + code. Note that there is no need for a location if the debug info + contains an integer constant. + FIXME: when the encoding-based debug scheme is dropped, move this + condition to the top-level IF block: we will not need to create a + variable anymore in such cases, then. */ + if (use_variable || (need_debug && !TREE_CONSTANT (gnu_expr))) return gnu_decl; } @@ -8650,6 +8545,28 @@ copy_and_substitute_in_size (tree new_type, tree old_type, TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type)); TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type)); } + +/* Add a parallel type to GNU_TYPE, the translation of GNAT_ENTITY, which is + the implementation type of a packed array type (Is_Packed_Array_Impl_Type). + The parallel type is the original array type if it has been translated. */ + +static void +add_parallel_type_for_packed_array (tree gnu_type, Entity_Id gnat_entity) +{ + Entity_Id gnat_original_array_type + = Underlying_Type (Original_Array_Type (gnat_entity)); + tree gnu_original_array_type; + + if (!present_gnu_tree (gnat_original_array_type)) + return; + + gnu_original_array_type = gnat_to_gnu_type (gnat_original_array_type); + + if (TYPE_IS_DUMMY_P (gnu_original_array_type)) + return; + + add_parallel_type (gnu_type, gnu_original_array_type); +} /* Given a type T, a FIELD_DECL F, and a replacement value R, return a type with all size expressions that contain F in a PLACEHOLDER_EXPR diff --git a/main/gcc/ada/gcc-interface/gigi.h b/main/gcc/ada/gcc-interface/gigi.h index 76fa2abde9f..6cee20b7304 100644 --- a/main/gcc/ada/gcc-interface/gigi.h +++ b/main/gcc/ada/gcc-interface/gigi.h @@ -143,7 +143,7 @@ extern tree make_packable_type (tree type, bool in_record); extern tree make_type_from_size (tree type, tree size_tree, bool for_biased); /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type - if needed. We have already verified that SIZE and TYPE are large enough. + if needed. We have already verified that SIZE and ALIGN are large enough. GNAT_ENTITY is used to name the resulting record and to issue a warning. 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. @@ -335,6 +335,9 @@ extern int double_float_alignment; types whose size is greater or equal to 64 bits, or 0 if this alignment is not specifically capped. */ extern int double_scalar_alignment; + +/* True if floating-point arithmetics may use wider intermediate results. */ +extern bool fp_arith_may_widen; /* Data structures used to represent attributes. */ @@ -392,10 +395,8 @@ enum standard_datatypes ADT_sbitsize_unit_node, /* Function declaration nodes for run-time functions for allocating memory. - Ada allocators cause calls to these functions to be generated. Malloc32 - is used only on 64bit systems needing to allocate 32bit memory. */ + Ada allocators cause calls to this function to be generated. */ ADT_malloc_decl, - ADT_malloc32_decl, /* Likewise for freeing memory. */ ADT_free_decl, @@ -449,7 +450,9 @@ enum inline_status_t /* No inlining is requested for the subprogram. */ is_disabled, /* Inlining is requested for the subprogram. */ - is_enabled + is_enabled, + /* Inlining is required for the subprogram. */ + is_required }; extern GTY(()) tree gnat_std_decls[(int) ADT_LAST]; @@ -466,7 +469,6 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1]; #define sbitsize_one_node gnat_std_decls[(int) ADT_sbitsize_one_node] #define sbitsize_unit_node gnat_std_decls[(int) ADT_sbitsize_unit_node] #define malloc_decl gnat_std_decls[(int) ADT_malloc_decl] -#define malloc32_decl gnat_std_decls[(int) ADT_malloc32_decl] #define free_decl gnat_std_decls[(int) ADT_free_decl] #define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl] #define parent_name_id gnat_std_decls[(int) ADT_parent_name_id] @@ -778,19 +780,6 @@ extern void rest_of_subprog_body_compilation (tree subprog_decl); Return a constructor for the template. */ extern tree build_template (tree template_type, tree array_type, tree expr); -/* Build a 64bit VMS descriptor from a Mechanism_Type, which must specify - a descriptor type, and the GCC type of an object. Each FIELD_DECL - in the type contains in its DECL_INITIAL the expression to use when - a constructor is made for the type. GNAT_ENTITY is a gnat node used - to print out an error message if the mechanism cannot be applied to - an object of that type and also for the name. */ -extern tree build_vms_descriptor (tree type, Mechanism_Type mech, - Entity_Id gnat_entity); - -/* Build a 32bit VMS descriptor from a Mechanism_Type. See above. */ -extern tree build_vms_descriptor32 (tree type, Mechanism_Type mech, - Entity_Id gnat_entity); - /* Build a type to be used to represent an aliased object whose nominal type is an unconstrained array. This consists of a RECORD_TYPE containing a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE. @@ -958,19 +947,6 @@ extern tree build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc, Entity_Id gnat_pool, Node_Id gnat_node, bool); -/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result. - GNAT_ACTUAL is the actual parameter for which the descriptor is built. */ -extern tree fill_vms_descriptor (tree gnu_type, tree gnu_expr, - Node_Id gnat_actual); - -/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular - pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) - pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the - descriptor is passed. */ -extern tree convert_vms_descriptor (tree gnu_type, tree gnu_expr, - tree gnu_expr_alt_type, - Entity_Id gnat_subprog); - /* Indicate that we need to take the address of T and that it therefore should not be allocated in a register. Returns true if successful. */ extern bool gnat_mark_addressable (tree t); @@ -1017,6 +993,18 @@ extern int fp_prec_to_size (int prec); /* Return the precision of the FP mode with size SIZE. */ extern int fp_size_to_prec (int size); +/* Return whether GNAT_NODE is a defining identifier for a renaming that comes + from the parameter association for the instantiation of a generic. We do + not want to emit source location for them: the code generated for their + initialization is likely to disturb debugging. */ +extern bool renaming_from_generic_instantiation_p (Node_Id gnat_node); + +/* Try to process all nodes in the deferred context queue. Keep in the queue + the ones that cannot be processed yet, remove the other ones. If FORCE is + true, force the processing for all nodes, use the global context when nodes + don't have a GNU translation. */ +extern void process_deferred_decl_context (bool force); + #ifdef __cplusplus extern "C" { #endif @@ -1056,19 +1044,6 @@ extern void enumerate_modes (void (*f) (const char *, int, int, int, int, int, } #endif -/* Let code know whether we are targeting VMS without need of - intrusive preprocessor directives. */ -#ifndef TARGET_ABI_OPEN_VMS -#define TARGET_ABI_OPEN_VMS 0 -#endif - -/* VMS option set by default, when clear forces 32bit mallocs and 32bit - Descriptors. Always used in combination with TARGET_ABI_OPEN_VMS - so no effect on non-VMS systems. */ -#if TARGET_ABI_OPEN_VMS == 0 -#define flag_vms_malloc64 0 -#endif - /* Convenient shortcuts. */ #define VECTOR_TYPE_P(TYPE) (TREE_CODE (TYPE) == VECTOR_TYPE) diff --git a/main/gcc/ada/gcc-interface/misc.c b/main/gcc/ada/gcc-interface/misc.c index fe44c6d5b3f..240ca445d21 100644 --- a/main/gcc/ada/gcc-interface/misc.c +++ b/main/gcc/ada/gcc-interface/misc.c @@ -407,13 +407,16 @@ gnat_init_gcc_fp (void) flag_signed_zeros = 0; /* Assume that FP operations can trap if S'Machine_Overflow is true, - but don't override the user if not. - - ??? Alpha/VMS enables FP traps without declaring it. */ - if (Machine_Overflows_On_Target || TARGET_ABI_OPEN_VMS) + but don't override the user if not. */ + if (Machine_Overflows_On_Target) flag_trapping_math = 1; else if (!global_options_set.x_flag_trapping_math) flag_trapping_math = 0; + + /* We don't care in Ada about errno, and it causes __builtin_sqrt to + to call the libm function rather than do it inline. */ + if (!global_options_set.x_flag_errno_math) + flag_errno_math = 0; } /* Print language-specific items in declaration NODE. */ @@ -464,8 +467,6 @@ gnat_print_type (FILE *file, tree node, int indent) else if (TYPE_HAS_ACTUAL_BOUNDS_P (node)) print_node (file, "actual bounds", TYPE_ACTUAL_BOUNDS (node), indent + 4); - else if (TYPE_VAX_FLOATING_POINT_P (node)) - ; else print_node (file, "index type", TYPE_INDEX_TYPE (node), indent + 4); @@ -712,6 +713,9 @@ enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int)) = { "float", "double", "long double" }; int iloop; + /* We are going to compute it below. */ + fp_arith_may_widen = false; + for (iloop = 0; iloop < NUM_MACHINE_MODES; iloop++) { enum machine_mode i = (enum machine_mode) iloop; @@ -761,6 +765,15 @@ enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int)) if (!fmt) continue; + /* Be conservative and consider that floating-point arithmetics may + use wider intermediate results as soon as there is an extended + Motorola or Intel mode supported by the machine. */ + if (fmt == &ieee_extended_motorola_format + || fmt == &ieee_extended_intel_96_format + || fmt == &ieee_extended_intel_96_round_53_format + || fmt == &ieee_extended_intel_128_format) + fp_arith_may_widen = true; + if (fmt->b == 2) digs = (fmt->p - 1) * 1233 / 4096; /* scale by log (2) */ @@ -769,11 +782,6 @@ enumerate_modes (void (*f) (const char *, int, int, int, int, int, int, int)) else gcc_unreachable(); - - if (fmt == &vax_f_format - || fmt == &vax_d_format - || fmt == &vax_g_format) - float_rep = VAX_Native; } /* First register any C types for this mode that the front end diff --git a/main/gcc/ada/gcc-interface/trans.c b/main/gcc/ada/gcc-interface/trans.c index e0ecf065c7d..8117ee8f546 100644 --- a/main/gcc/ada/gcc-interface/trans.c +++ b/main/gcc/ada/gcc-interface/trans.c @@ -36,7 +36,7 @@ #include "output.h" #include "libfuncs.h" /* For set_stack_check_libfunc. */ #include "tree-iterator.h" -#include "pointer-set.h" +#include "hash-set.h" #include "gimple-expr.h" #include "gimplify.h" #include "bitmap.h" @@ -76,18 +76,6 @@ static location_t block_end_locus_sink; #define BLOCK_SOURCE_END_LOCATION(BLOCK) block_end_locus_sink #endif -/* For efficient float-to-int rounding, it is necessary to know whether - floating-point arithmetic may use wider intermediate results. When - FP_ARITH_MAY_WIDEN is not defined, be conservative and only assume - that arithmetic does not widen if double precision is emulated. */ -#ifndef FP_ARITH_MAY_WIDEN -#if defined(HAVE_extendsfdf2) -#define FP_ARITH_MAY_WIDEN HAVE_extendsfdf2 -#else -#define FP_ARITH_MAY_WIDEN 0 -#endif -#endif - /* Pointers to front-end tables accessed through macros. */ struct Node *Nodes_Ptr; struct Flags *Flags_Ptr; @@ -297,8 +285,7 @@ gigi (Node_Id gnat_root, { Node_Id gnat_iter; Entity_Id gnat_literal; - tree long_long_float_type, exception_type, t, ftype; - tree int64_type = gnat_type_for_size (64, 0); + tree t, ftype, int64_type; struct elab_info *info; int i; @@ -316,10 +303,6 @@ gigi (Node_Id gnat_root, type_annotate_only = (gigi_operating_mode == 1); -#if TARGET_ABI_OPEN_VMS - vms_float_format = Float_Format; -#endif - for (i = 0; i < number_file; i++) { /* Use the identifier table to make a permanent copy of the filename as @@ -424,14 +407,6 @@ gigi (Node_Id gnat_root, NULL, Empty); DECL_IS_MALLOC (malloc_decl) = 1; - /* malloc32 is a function declaration tree for a function to allocate - 32-bit memory on a 64-bit system. Needed only on 64-bit VMS. */ - malloc32_decl - = create_subprog_decl (get_identifier ("__gnat_malloc32"), NULL_TREE, - ftype, NULL_TREE, is_disabled, true, true, true, - NULL, Empty); - DECL_IS_MALLOC (malloc32_decl) = 1; - /* free is a function declaration tree for a function to free memory. */ free_decl = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE, @@ -442,6 +417,7 @@ gigi (Node_Id gnat_root, Empty); /* This is used for 64-bit multiplication with overflow checking. */ + int64_type = gnat_type_for_size (64, 0); mulv64_decl = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE, build_function_type_list (int64_type, int64_type, @@ -569,9 +545,7 @@ gigi (Node_Id gnat_root, } /* Set the types that GCC and Gigi use from the front end. */ - exception_type - = gnat_to_gnu_entity (Base_Type (standard_exception_type), NULL_TREE, 0); - except_type_node = TREE_TYPE (exception_type); + except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type)); /* Make other functions used for exception processing. */ get_excptr_decl @@ -636,21 +610,8 @@ gigi (Node_Id gnat_root, null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec); } - long_long_float_type - = gnat_to_gnu_entity (Base_Type (standard_long_long_float), NULL_TREE, 0); - - if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE) - { - /* In this case, the builtin floating point types are VAX float, - so make up a type for use. */ - longest_float_type_node = make_node (REAL_TYPE); - TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE; - layout_type (longest_float_type_node); - record_builtin_type ("longest float type", longest_float_type_node, - false); - } - else - longest_float_type_node = TREE_TYPE (long_long_float_type); + longest_float_type_node + = get_unpadded_type (Base_Type (standard_long_long_float)); /* 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 @@ -804,12 +765,15 @@ lvalue_required_for_attribute_p (Node_Id gnat_node) case Attr_Object_Size: case Attr_Value_Size: case Attr_Component_Size: + case Attr_Descriptor_Size: case Attr_Max_Size_In_Storage_Elements: case Attr_Min: case Attr_Max: case Attr_Null_Parameter: case Attr_Passed_By_Reference: case Attr_Mechanism_Code: + case Attr_Machine: + case Attr_Model: return 0; case Attr_Address: @@ -1453,7 +1417,8 @@ Pragma_to_gnu (Node_Id gnat_node) gcc_unreachable (); } - if (Present (Next (gnat_temp))) + /* Deal with optional pattern (but ignore Reason => "..."). */ + if (Present (Next (gnat_temp)) && No (Chars (Next (gnat_temp)))) { /* pragma Warnings (On | Off, Name) is handled differently. */ if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal) @@ -1506,6 +1471,38 @@ Pragma_to_gnu (Node_Id gnat_node) return gnu_result; } +/* Return an expression for the length of TYPE, an integral type, computed in + RESULT_TYPE, another integral type. + + We used to compute the length as MAX (hb - lb + 1, 0) which could overflow + when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0 + which would only overflow in much rarer cases, for extremely large arrays + we expect never to encounter in practice. Besides, the former computation + required the use of potentially constraining signed arithmetics while the + latter does not. Note that the comparison must be done in the original + base index type in order to avoid any overflow during the conversion. */ + +static tree +get_type_length (tree type, tree result_type) +{ + tree comp_type = get_base_type (result_type); + tree base_type = get_base_type (type); + tree lb = convert (base_type, TYPE_MIN_VALUE (type)); + tree hb = convert (base_type, TYPE_MAX_VALUE (type)); + tree length + = build_binary_op (PLUS_EXPR, comp_type, + build_binary_op (MINUS_EXPR, comp_type, + convert (comp_type, hb), + convert (comp_type, lb)), + convert (comp_type, integer_one_node)); + length + = build_cond_expr (result_type, + build_binary_op (GE_EXPR, boolean_type_node, hb, lb), + convert (result_type, length), + convert (result_type, integer_zero_node)); + return length; +} + /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node, to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to where we should place the result type. ATTRIBUTE is the attribute ID. */ @@ -1895,20 +1892,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) else if (attribute == Attr_Last) gnu_result = TYPE_MAX_VALUE (gnu_type); else - gnu_result - = build_binary_op - (MAX_EXPR, get_base_type (gnu_result_type), - build_binary_op - (PLUS_EXPR, get_base_type (gnu_result_type), - build_binary_op (MINUS_EXPR, - get_base_type (gnu_result_type), - convert (gnu_result_type, - TYPE_MAX_VALUE (gnu_type)), - convert (gnu_result_type, - TYPE_MIN_VALUE (gnu_type))), - convert (gnu_result_type, integer_one_node)), - convert (gnu_result_type, integer_zero_node)); - + gnu_result = get_type_length (gnu_type, gnu_result_type); break; } @@ -1992,8 +1976,16 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE); /* When not optimizing, look up the slot associated with the parameter - and the dimension in the cache and create a new one on failure. */ - if (!optimize && Present (gnat_param)) + and the dimension in the cache and create a new one on failure. + Don't do this when the actual subtype needs debug info (this happens + with -gnatD): in elaborate_expression_1, we create variables that + hold the bounds, so caching attributes isn't very interesting and + causes dependency issues between these variables and cached + expressions. */ + if (!optimize + && Present (gnat_param) + && !(Present (Actual_Subtype (gnat_param)) + && Needs_Debug_Info (Actual_Subtype (gnat_param)))) { FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa) if (pa->id == gnat_param && pa->dim == Dimension) @@ -2040,37 +2032,10 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) gnu_result = pa->length; break; } - else - { - /* We used to compute the length as max (hb - lb + 1, 0), - which could overflow for some cases of empty arrays, e.g. - when lb == index_type'first. We now compute the length as - (hb >= lb) ? hb - lb + 1 : 0, which would only overflow in - much rarer cases, for extremely large arrays we expect - never to encounter in practice. In addition, the former - computation required the use of potentially constraining - signed arithmetic while the latter doesn't. Note that - the comparison must be done in the original index type, - to avoid any overflow during the conversion. */ - tree comp_type = get_base_type (gnu_result_type); - tree index_type = TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)); - tree lb = TYPE_MIN_VALUE (index_type); - tree hb = TYPE_MAX_VALUE (index_type); - gnu_result - = build_binary_op (PLUS_EXPR, comp_type, - build_binary_op (MINUS_EXPR, - comp_type, - convert (comp_type, hb), - convert (comp_type, lb)), - convert (comp_type, integer_one_node)); - gnu_result - = build_cond_expr (comp_type, - build_binary_op (GE_EXPR, - boolean_type_node, - hb, lb), - gnu_result, - convert (comp_type, integer_zero_node)); - } + + gnu_result + = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)), + gnu_result_type); } /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are @@ -2334,6 +2299,56 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) } break; + case Attr_Model: + /* We treat Model as identical to Machine. This is true for at least + IEEE and some other nice floating-point systems. */ + + /* ... fall through ... */ + + case Attr_Machine: + /* The trick is to force the compiler to store the result in memory so + that we do not have extra precision used. But do this only when this + is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of + the type is lower than that of the longest floating-point type. */ + prefix_unused = true; + gnu_expr = gnat_to_gnu (First (Expressions (gnat_node))); + gnu_result_type = get_unpadded_type (Etype (gnat_node)); + gnu_result = convert (gnu_result_type, gnu_expr); + + if (fp_arith_may_widen + && TYPE_PRECISION (gnu_result_type) + < TYPE_PRECISION (longest_float_type_node)) + { + tree rec_type = make_node (RECORD_TYPE); + tree field + = create_field_decl (get_identifier ("OBJ"), gnu_result_type, + rec_type, NULL_TREE, NULL_TREE, 0, 0); + tree rec_val, asm_expr; + + finish_record_type (rec_type, field, 0, false); + + rec_val = build_constructor_single (rec_type, field, gnu_result); + rec_val = save_expr (rec_val); + + asm_expr + = build5 (ASM_EXPR, void_type_node, + build_string (0, ""), + tree_cons (build_tree_list (NULL_TREE, + build_string (2, "=m")), + rec_val, NULL_TREE), + tree_cons (build_tree_list (NULL_TREE, + build_string (1, "m")), + rec_val, NULL_TREE), + NULL_TREE, NULL_TREE); + ASM_VOLATILE_P (asm_expr) = 1; + + gnu_result + = build_compound_expr (gnu_result_type, asm_expr, + build_component_ref (rec_val, NULL_TREE, + field, false)); + } + break; + default: /* This abort means that we have an unimplemented attribute. */ gcc_unreachable (); @@ -2347,7 +2362,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) && TREE_SIDE_EFFECTS (gnu_prefix) && !Is_Entity_Name (gnat_prefix)) gnu_result - = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result); + = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result); *gnu_result_type_p = gnu_result_type; return gnu_result; @@ -2400,9 +2415,11 @@ Case_Statement_to_gnu (Node_Id gnat_node) /* First compile all the different case choices for the current WHEN alternative. */ for (gnat_choice = First (Discrete_Choices (gnat_when)); - Present (gnat_choice); gnat_choice = Next (gnat_choice)) + Present (gnat_choice); + gnat_choice = Next (gnat_choice)) { tree gnu_low = NULL_TREE, gnu_high = NULL_TREE; + tree label = create_artificial_label (input_location); switch (Nkind (gnat_choice)) { @@ -2426,8 +2443,8 @@ Case_Statement_to_gnu (Node_Id gnat_node) { tree gnu_type = get_unpadded_type (Entity (gnat_choice)); - gnu_low = fold (TYPE_MIN_VALUE (gnu_type)); - gnu_high = fold (TYPE_MAX_VALUE (gnu_type)); + gnu_low = TYPE_MIN_VALUE (gnu_type); + gnu_high = TYPE_MAX_VALUE (gnu_type); break; } @@ -2445,20 +2462,13 @@ Case_Statement_to_gnu (Node_Id gnat_node) gcc_unreachable (); } - /* If the case value is a subtype that raises Constraint_Error at - run time because of a wrong bound, then gnu_low or gnu_high is - not translated into an INTEGER_CST. In such a case, we need - to ensure that the when statement is not added in the tree, - otherwise it will crash the gimplifier. */ - if ((!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST) - && (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST)) - { - add_stmt_with_node (build_case_label - (gnu_low, gnu_high, - create_artificial_label (input_location)), - gnat_choice); - choices_added_p = true; - } + /* Everything should be folded into constants at this point. */ + gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST); + gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST); + + add_stmt_with_node (build_case_label (gnu_low, gnu_high, label), + gnat_choice); + choices_added_p = true; } /* This construct doesn't define a scope so we shouldn't push a binding @@ -2643,8 +2653,8 @@ Loop_Statement_to_gnu (Node_Id gnat_node) enum tree_code update_code, test_code, shift_code; bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false; - gnu_low = TYPE_MIN_VALUE (gnu_type); - gnu_high = TYPE_MAX_VALUE (gnu_type); + gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type)); + gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type)); /* We must disable modulo reduction for the iteration variable, if any, in order for the loop comparison to be effective. */ @@ -2937,61 +2947,6 @@ Loop_Statement_to_gnu (Node_Id gnat_node) return gnu_result; } -/* Emit statements to establish __gnat_handle_vms_condition as a VMS condition - handler for the current function. */ - -/* This is implemented by issuing a call to the appropriate VMS specific - builtin. To avoid having VMS specific sections in the global gigi decls - array, we maintain the decls of interest here. We can't declare them - inside the function because we must mark them never to be GC'd, which we - can only do at the global level. */ - -static GTY(()) tree vms_builtin_establish_handler_decl = NULL_TREE; -static GTY(()) tree gnat_vms_condition_handler_decl = NULL_TREE; - -static void -establish_gnat_vms_condition_handler (void) -{ - tree establish_stmt; - - /* Elaborate the required decls on the first call. Check on the decl for - the gnat condition handler to decide, as this is one we create so we are - sure that it will be non null on subsequent calls. The builtin decl is - looked up so remains null on targets where it is not implemented yet. */ - if (gnat_vms_condition_handler_decl == NULL_TREE) - { - vms_builtin_establish_handler_decl - = builtin_decl_for - (get_identifier ("__builtin_establish_vms_condition_handler")); - - gnat_vms_condition_handler_decl - = create_subprog_decl (get_identifier ("__gnat_handle_vms_condition"), - NULL_TREE, - build_function_type_list (boolean_type_node, - ptr_void_type_node, - ptr_void_type_node, - NULL_TREE), - NULL_TREE, is_disabled, true, true, true, NULL, - Empty); - - /* ??? DECL_CONTEXT shouldn't have been set because of DECL_EXTERNAL. */ - DECL_CONTEXT (gnat_vms_condition_handler_decl) = NULL_TREE; - } - - /* Do nothing if the establish builtin is not available, which might happen - on targets where the facility is not implemented. */ - if (vms_builtin_establish_handler_decl == NULL_TREE) - return; - - establish_stmt - = build_call_n_expr (vms_builtin_establish_handler_decl, 1, - build_unary_op - (ADDR_EXPR, NULL_TREE, - gnat_vms_condition_handler_decl)); - - add_stmt (establish_stmt); -} - /* This page implements a form of Named Return Value optimization modelled on the C++ optimization of the same name. The main difference is that we disregard any semantical considerations when applying it here, the @@ -3054,7 +3009,7 @@ struct nrv_data bitmap nrv; tree result; Node_Id gnat_ret; - struct pointer_set_t *visited; + hash_set *visited; }; /* Return true if T is a Named Return Value. */ @@ -3188,7 +3143,7 @@ finalize_nrv_r (tree *tp, int *walk_subtrees, void *data) /* Avoid walking into the same tree more than once. Unfortunately, we can't just use walk_tree_without_duplicates because it would only call us for the first occurrence of NRVs in the function body. */ - if (pointer_set_insert (dp->visited, *tp)) + if (dp->visited->add (*tp)) *walk_subtrees = 0; return NULL_TREE; @@ -3328,7 +3283,7 @@ finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data) /* Avoid walking into the same tree more than once. Unfortunately, we can't just use walk_tree_without_duplicates because it would only call us for the first occurrence of NRVs in the function body. */ - if (pointer_set_insert (dp->visited, *tp)) + if (dp->visited->add (*tp)) *walk_subtrees = 0; return NULL_TREE; @@ -3361,7 +3316,7 @@ finalize_nrv (tree fndecl, bitmap nrv, vec *other, Node_Id gnat_ret return; /* Prune also the candidates that are referenced by nested functions. */ - node = cgraph_get_create_node (fndecl); + node = cgraph_node::get_create (fndecl); for (node = node->nested; node; node = node->next_nested) walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), prune_nrv_r, &data); @@ -3376,13 +3331,13 @@ finalize_nrv (tree fndecl, bitmap nrv, vec *other, Node_Id gnat_ret data.nrv = nrv; data.result = DECL_RESULT (fndecl); data.gnat_ret = gnat_ret; - data.visited = pointer_set_create (); + data.visited = new hash_set; if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl))) func = finalize_nrv_unc_r; else func = finalize_nrv_r; walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL); - pointer_set_destroy (data.visited); + delete data.visited; } /* Return true if RET_VAL can be used as a Named Return Value for the @@ -3485,69 +3440,6 @@ build_return_expr (tree ret_obj, tree ret_val) return build1 (RETURN_EXPR, void_type_node, result_expr); } - -/* Build a stub for the subprogram specified by the GCC tree GNU_SUBPROG - and the GNAT node GNAT_SUBPROG. */ - -static void -build_function_stub (tree gnu_subprog, Entity_Id gnat_subprog) -{ - tree gnu_subprog_type, gnu_subprog_addr, gnu_subprog_call; - tree gnu_subprog_param, gnu_stub_param, gnu_param; - tree gnu_stub_decl = DECL_FUNCTION_STUB (gnu_subprog); - vec *gnu_param_vec = NULL; - - gnu_subprog_type = TREE_TYPE (gnu_subprog); - - /* Initialize the information structure for the function. */ - allocate_struct_function (gnu_stub_decl, false); - set_cfun (NULL); - - begin_subprog_body (gnu_stub_decl); - - start_stmt_group (); - gnat_pushlevel (); - - /* Loop over the parameters of the stub and translate any of them - passed by descriptor into a by reference one. */ - for (gnu_stub_param = DECL_ARGUMENTS (gnu_stub_decl), - gnu_subprog_param = DECL_ARGUMENTS (gnu_subprog); - gnu_stub_param; - gnu_stub_param = DECL_CHAIN (gnu_stub_param), - gnu_subprog_param = DECL_CHAIN (gnu_subprog_param)) - { - if (DECL_BY_DESCRIPTOR_P (gnu_stub_param)) - { - gcc_assert (DECL_BY_REF_P (gnu_subprog_param)); - gnu_param - = convert_vms_descriptor (TREE_TYPE (gnu_subprog_param), - gnu_stub_param, - DECL_PARM_ALT_TYPE (gnu_stub_param), - gnat_subprog); - } - else - gnu_param = gnu_stub_param; - - vec_safe_push (gnu_param_vec, gnu_param); - } - - /* Invoke the internal subprogram. */ - gnu_subprog_addr = build1 (ADDR_EXPR, build_pointer_type (gnu_subprog_type), - gnu_subprog); - gnu_subprog_call = build_call_vec (TREE_TYPE (gnu_subprog_type), - gnu_subprog_addr, gnu_param_vec); - - /* Propagate the return value, if any. */ - if (VOID_TYPE_P (TREE_TYPE (gnu_subprog_type))) - add_stmt (gnu_subprog_call); - else - add_stmt (build_return_expr (DECL_RESULT (gnu_stub_decl), - gnu_subprog_call)); - - gnat_poplevel (); - end_subprog_body (end_stmt_group ()); - rest_of_subprog_body_compilation (gnu_stub_decl); -} /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We don't return anything. */ @@ -3696,22 +3588,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) start_stmt_group (); gnat_pushlevel (); - /* On VMS, establish our condition handler to possibly turn a condition into - the corresponding exception if the subprogram has a foreign convention or - is exported. - - To ensure proper execution of local finalizations on condition instances, - we must turn a condition into the corresponding exception even if there - is no applicable Ada handler, and need at least one condition handler per - possible call chain involving GNAT code. OTOH, establishing the handler - has a cost so we want to minimize the number of subprograms into which - this happens. The foreign or exported condition is expected to satisfy - all the constraints. */ - if (TARGET_ABI_OPEN_VMS - && (Has_Foreign_Convention (gnat_subprog_id) - || Is_Exported (gnat_subprog_id))) - establish_gnat_vms_condition_handler (); - process_decls (Declarations (gnat_node), Empty, Empty, true, true); /* Generate the code of the subprogram itself. A return statement will be @@ -3844,10 +3720,6 @@ Subprogram_Body_to_gnu (Node_Id gnat_node) } rest_of_subprog_body_compilation (gnu_subprog_decl); - - /* If there is a stub associated with the function, build it now. */ - if (DECL_FUNCTION_STUB (gnu_subprog_decl)) - build_function_stub (gnu_subprog_decl, gnat_subprog_id); } /* Return true if GNAT_NODE requires atomic synchronization. */ @@ -4057,10 +3929,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, const bool is_true_formal_parm = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL; const bool is_by_ref_formal_parm - = is_true_formal_parm - && (DECL_BY_REF_P (gnu_formal) - || DECL_BY_COMPONENT_PTR_P (gnu_formal) - || DECL_BY_DESCRIPTOR_P (gnu_formal)); + = is_true_formal_parm + && (DECL_BY_REF_P (gnu_formal) + || DECL_BY_COMPONENT_PTR_P (gnu_formal)); /* In the Out or In Out case, we must suppress conversions that yield an lvalue but can nevertheless cause the creation of a temporary, because we need the real object in this case, either to pass its @@ -4317,24 +4188,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual); } - /* Then see if the parameter is passed by descriptor. */ - else if (is_true_formal_parm && DECL_BY_DESCRIPTOR_P (gnu_formal)) - { - gnu_actual = convert (gnu_formal_type, gnu_actual); - - /* If this is 'Null_Parameter, pass a zero descriptor. */ - if ((TREE_CODE (gnu_actual) == INDIRECT_REF - || TREE_CODE (gnu_actual) == UNCONSTRAINED_ARRAY_REF) - && TREE_PRIVATE (gnu_actual)) - gnu_actual - = convert (DECL_ARG_TYPE (gnu_formal), integer_zero_node); - else - gnu_actual = build_unary_op (ADDR_EXPR, NULL_TREE, - fill_vms_descriptor - (TREE_TYPE (TREE_TYPE (gnu_formal)), - gnu_actual, gnat_actual)); - } - /* Otherwise the parameter is passed by copy. */ else { @@ -4448,10 +4301,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target, if (!(present_gnu_tree (gnat_formal) && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL && (DECL_BY_REF_P (get_gnu_tree (gnat_formal)) - || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL - && ((DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)) - || (DECL_BY_DESCRIPTOR_P - (get_gnu_tree (gnat_formal)))))))) + || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal)))) && Ekind (gnat_formal) != E_In_Parameter) { /* Get the value to assign to this Out or In Out parameter. It is @@ -4904,26 +4754,7 @@ Exception_Handler_to_gnu_sjlj (Node_Id gnat_node) gnu_except_ptr_stack->last (), convert (TREE_TYPE (gnu_except_ptr_stack->last ()), build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr))); - - /* If this is the distinguished exception "Non_Ada_Error" (and we are - in VMS mode), also allow a non-Ada exception (a VMS condition) t - match. */ - if (Is_Non_Ada_Error (Entity (gnat_temp))) - { - tree gnu_comp - = build_component_ref - (build_unary_op (INDIRECT_REF, NULL_TREE, - gnu_except_ptr_stack->last ()), - get_identifier ("lang"), NULL_TREE, false); - - this_choice - = build_binary_op - (TRUTH_ORIF_EXPR, boolean_type_node, - build_binary_op (EQ_EXPR, boolean_type_node, gnu_comp, - build_int_cst (TREE_TYPE (gnu_comp), 'V')), - this_choice); - } - } +} else gcc_unreachable (); @@ -4971,9 +4802,6 @@ Exception_Handler_to_gnu_zcx (Node_Id gnat_node) gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0); gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr); - - /* The Non_Ada_Error case for VMS exceptions is handled - by the personality routine. */ } else gcc_unreachable (); @@ -5056,6 +4884,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) const bool body_p = (Nkind (gnat_unit) == N_Package_Body || Nkind (gnat_unit) == N_Subprogram_Body); const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit); + Entity_Id gnat_entity; Node_Id gnat_pragma; /* Make the decl for the elaboration procedure. */ tree gnu_elab_proc_decl @@ -5104,33 +4933,31 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) /* Process the unit itself. */ add_stmt (gnat_to_gnu (gnat_unit)); - /* If we can inline, generate code for all the inlined subprograms. */ - if (optimize) + /* Generate code for all the inlined subprograms. */ + for (gnat_entity = First_Inlined_Subprogram (gnat_node); + Present (gnat_entity); + gnat_entity = Next_Inlined_Subprogram (gnat_entity)) { - Entity_Id gnat_entity; + Node_Id gnat_body; - for (gnat_entity = First_Inlined_Subprogram (gnat_node); - Present (gnat_entity); - gnat_entity = Next_Inlined_Subprogram (gnat_entity)) - { - Node_Id gnat_body = Parent (Declaration_Node (gnat_entity)); + /* Without optimization, process only the required subprograms. */ + if (!optimize && !Has_Pragma_Inline_Always (gnat_entity)) + continue; - if (Nkind (gnat_body) != N_Subprogram_Body) - { - /* ??? This really should always be present. */ - if (No (Corresponding_Body (gnat_body))) - continue; - gnat_body - = Parent (Declaration_Node (Corresponding_Body (gnat_body))); - } + gnat_body = Parent (Declaration_Node (gnat_entity)); + if (Nkind (gnat_body) != N_Subprogram_Body) + { + /* ??? This happens when only the spec of a package is provided. */ + if (No (Corresponding_Body (gnat_body))) + continue; - if (Present (gnat_body)) - { - /* Define the entity first so we set DECL_EXTERNAL. */ - gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); - add_stmt (gnat_to_gnu (gnat_body)); - } + gnat_body + = Parent (Declaration_Node (Corresponding_Body (gnat_body))); } + + /* Define the entity first so we set DECL_EXTERNAL. */ + gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0); + add_stmt (gnat_to_gnu (gnat_body)); } /* Process any pragmas and actions following the unit. */ @@ -5160,6 +4987,9 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) stabilization of the renamed entities may create SAVE_EXPRs which have been tied to a specific elaboration routine just above. */ invalidate_global_renaming_pointers (); + + /* Force the processing for all nodes that remain in the queue. */ + process_deferred_decl_context (true); } /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Raise_xxx_Error, @@ -5509,13 +5339,6 @@ gnat_to_gnu (Node_Id gnat_node) gcc_assert (!TREE_OVERFLOW (gnu_result)); } - /* Convert the Ureal to a vax float (represented on a signed type). */ - else if (Vax_Float (Underlying_Type (Etype (gnat_node)))) - { - gnu_result = UI_To_gnu (Get_Vax_Real_Literal_As_Signed (gnat_node), - gnu_result_type); - } - else { Ureal ur_realval = Realval (gnat_node); @@ -5713,16 +5536,27 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = alloc_stmt_list (); break; + case N_Exception_Renaming_Declaration: + gnat_temp = Defining_Entity (gnat_node); + if (Renamed_Entity (gnat_temp) != Empty) + gnu_result + = gnat_to_gnu_entity (gnat_temp, + gnat_to_gnu (Renamed_Entity (gnat_temp)), 1); + else + gnu_result = alloc_stmt_list (); + break; + case N_Implicit_Label_Declaration: gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1); gnu_result = alloc_stmt_list (); break; - case N_Exception_Renaming_Declaration: case N_Number_Declaration: - case N_Package_Renaming_Declaration: case N_Subprogram_Renaming_Declaration: + case N_Package_Renaming_Declaration: /* These are fully handled in the front end. */ + /* ??? For package renamings, find a way to use GENERIC namespaces so + that we get proper debug information for them. */ gnu_result = alloc_stmt_list (); break; @@ -5812,8 +5646,18 @@ gnat_to_gnu (Node_Id gnat_node) TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))), gnat_temp); - gnu_result = build_binary_op (ARRAY_REF, NULL_TREE, - gnu_result, gnu_expr); + gnu_result + = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr); + + /* Array accesses are bound-checked so they cannot trap, but this + is valid only if they are not hoisted ahead of the check. We + need to mark them as no-trap to get decent loop optimizations + in the presence of -fnon-call-exceptions, so we do it when we + know that the original expression had no side-effects. */ + if (TREE_CODE (gnu_result) == ARRAY_REF + && !(Nkind (gnat_temp) == N_Identifier + && Ekind (Entity (gnat_temp)) == E_Constant)) + TREE_THIS_NOTRAP (gnu_result) = 1; } gnu_result_type = get_unpadded_type (Etype (gnat_node)); @@ -5915,25 +5759,16 @@ gnat_to_gnu (Node_Id gnat_node) case N_Selected_Component: { - tree gnu_prefix = gnat_to_gnu (Prefix (gnat_node)); + Entity_Id gnat_prefix = Prefix (gnat_node); Entity_Id gnat_field = Entity (Selector_Name (gnat_node)); - Entity_Id gnat_pref_type = Etype (Prefix (gnat_node)); + tree gnu_prefix = gnat_to_gnu (gnat_prefix); tree gnu_field; - while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind) - || IN (Ekind (gnat_pref_type), Access_Kind)) - { - if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)) - gnat_pref_type = Underlying_Type (gnat_pref_type); - else if (IN (Ekind (gnat_pref_type), Access_Kind)) - gnat_pref_type = Designated_Type (gnat_pref_type); - } - gnu_prefix = maybe_implicit_deref (gnu_prefix); /* For discriminant references in tagged types always substitute the corresponding discriminant as the actual selected component. */ - if (Is_Tagged_Type (gnat_pref_type)) + if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix)))) while (Present (Corresponding_Discriminant (gnat_field))) gnat_field = Corresponding_Discriminant (gnat_field); @@ -6142,9 +5977,12 @@ gnat_to_gnu (Node_Id gnat_node) || 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 = TYPE_MIN_VALUE (gnu_range_type); - gnu_high = TYPE_MAX_VALUE (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 (); @@ -6479,40 +6317,79 @@ gnat_to_gnu (Node_Id gnat_node) atomic_sync_required_p (Name (gnat_node))); else { - gnu_rhs - = maybe_unconstrained_array (gnat_to_gnu (Expression (gnat_node))); + const Node_Id gnat_expr = Expression (gnat_node); + const Entity_Id gnat_type + = Underlying_Type (Etype (Name (gnat_node))); + const bool regular_array_type_p + = (Is_Array_Type (gnat_type) && !Is_Bit_Packed_Array (gnat_type)); + const bool use_memset_p + = (regular_array_type_p + && Nkind (gnat_expr) == N_Aggregate + && Is_Others_Aggregate (gnat_expr)); + + /* If we'll use memset, we need to find the inner expression. */ + if (use_memset_p) + { + Node_Id gnat_inner + = Expression (First (Component_Associations (gnat_expr))); + while (Nkind (gnat_inner) == N_Aggregate + && Is_Others_Aggregate (gnat_inner)) + gnat_inner + = Expression (First (Component_Associations (gnat_inner))); + gnu_rhs = gnat_to_gnu (gnat_inner); + } + else + gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr)); /* If range check is needed, emit code to generate it. */ - if (Do_Range_Check (Expression (gnat_node))) + if (Do_Range_Check (gnat_expr)) gnu_rhs = emit_range_check (gnu_rhs, Etype (Name (gnat_node)), gnat_node); + /* If atomic synchronization is required, build an atomic store. */ if (atomic_sync_required_p (Name (gnat_node))) gnu_result = build_atomic_store (gnu_lhs, gnu_rhs); + + /* Or else, use memset when the conditions are met. */ + else if (use_memset_p) + { + tree value = fold_convert (integer_type_node, gnu_rhs); + tree to = gnu_lhs; + tree type = TREE_TYPE (to); + tree size + = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), to); + tree to_ptr = build_fold_addr_expr (to); + tree t = builtin_decl_implicit (BUILT_IN_MEMSET); + if (TREE_CODE (value) == INTEGER_CST) + { + tree mask + = build_int_cst (integer_type_node, + ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1); + value = int_const_binop (BIT_AND_EXPR, value, mask); + } + gnu_result = build_call_expr (t, 3, to_ptr, value, size); + } + + /* Otherwise build a regular assignment. */ else gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs); - /* If the type being assigned is an array type and the two sides are + /* If the assignment type is a regular array and the two sides are not completely disjoint, play safe and use memmove. But don't do it for a bit-packed array as it might not be byte-aligned. */ if (TREE_CODE (gnu_result) == MODIFY_EXPR - && Is_Array_Type (Etype (Name (gnat_node))) - && !Is_Bit_Packed_Array (Etype (Name (gnat_node))) + && regular_array_type_p && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node))) { - tree to, from, size, to_ptr, from_ptr, t; - - to = TREE_OPERAND (gnu_result, 0); - from = TREE_OPERAND (gnu_result, 1); - - size = TYPE_SIZE_UNIT (TREE_TYPE (from)); - size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, from); - - to_ptr = build_fold_addr_expr (to); - from_ptr = build_fold_addr_expr (from); - - t = builtin_decl_implicit (BUILT_IN_MEMMOVE); + tree to = TREE_OPERAND (gnu_result, 0); + tree from = TREE_OPERAND (gnu_result, 1); + tree type = TREE_TYPE (from); + tree size + = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from); + tree to_ptr = build_fold_addr_expr (to); + tree from_ptr = build_fold_addr_expr (from); + tree t = builtin_decl_implicit (BUILT_IN_MEMMOVE); gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size); } } @@ -7457,7 +7334,10 @@ add_stmt_force (tree gnu_stmt) void add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node) { - if (Present (gnat_node)) + /* Do not emit a location for renamings that come from generic instantiation, + they are likely to disturb debugging. */ + if (Present (gnat_node) + && !renaming_from_generic_instantiation_p (gnat_node)) set_expr_location_from_node (gnu_stmt, gnat_node); add_stmt (gnu_stmt); } @@ -8025,10 +7905,22 @@ process_freeze_entity (Node_Id gnat_node) if (gnu_old) { save_gnu_tree (gnat_entity, NULL_TREE, false); + if (IN (kind, Incomplete_Or_Private_Kind) - && Present (Full_View (gnat_entity)) - && present_gnu_tree (Full_View (gnat_entity))) - save_gnu_tree (Full_View (gnat_entity), NULL_TREE, false); + && Present (Full_View (gnat_entity))) + { + Entity_Id full_view = Full_View (gnat_entity); + + save_gnu_tree (full_view, NULL_TREE, false); + + if (IN (Ekind (full_view), Private_Kind) + && Present (Underlying_Full_View (full_view))) + { + full_view = Underlying_Full_View (full_view); + save_gnu_tree (full_view, NULL_TREE, false); + } + } + if (IN (kind, Type_Kind) && Present (Class_Wide_Type (gnat_entity)) && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity) @@ -8038,17 +7930,23 @@ process_freeze_entity (Node_Id gnat_node) if (IN (kind, Incomplete_Or_Private_Kind) && Present (Full_View (gnat_entity))) { - gnu_new = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 1); + Entity_Id full_view = Full_View (gnat_entity); + + if (IN (Ekind (full_view), Private_Kind) + && Present (Underlying_Full_View (full_view))) + full_view = Underlying_Full_View (full_view); + + gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1); /* Propagate back-annotations from full view to partial view. */ if (Unknown_Alignment (gnat_entity)) - Set_Alignment (gnat_entity, Alignment (Full_View (gnat_entity))); + Set_Alignment (gnat_entity, Alignment (full_view)); if (Unknown_Esize (gnat_entity)) - Set_Esize (gnat_entity, Esize (Full_View (gnat_entity))); + Set_Esize (gnat_entity, Esize (full_view)); if (Unknown_RM_Size (gnat_entity)) - Set_RM_Size (gnat_entity, RM_Size (Full_View (gnat_entity))); + Set_RM_Size (gnat_entity, RM_Size (full_view)); /* The above call may have defined this entity (the simplest example of this is when we have a private enumeral type since the bounds @@ -8242,32 +8140,37 @@ static tree build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, tree right, Node_Id gnat_node) { + const unsigned int precision = TYPE_PRECISION (gnu_type); tree lhs = gnat_protect_expr (left); tree rhs = gnat_protect_expr (right); tree type_max = TYPE_MAX_VALUE (gnu_type); tree type_min = TYPE_MIN_VALUE (gnu_type); - tree gnu_expr; - tree tmp1, tmp2; tree zero = convert (gnu_type, integer_zero_node); - tree rhs_lt_zero; - tree check_pos; - tree check_neg; - tree check; - int precision = TYPE_PRECISION (gnu_type); + tree gnu_expr, rhs_lt_zero, tmp1, tmp2; + tree check_pos, check_neg, check; - gcc_assert (!(precision & (precision - 1))); /* ensure power of 2 */ + /* 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)))) + && (TREE_CONSTANT (lhs) + || (!tree_expr_nonnegative_p (rhs) + && tree_expr_nonnegative_p (lhs)))) { tree tmp = lhs; lhs = rhs; rhs = tmp; } + gnu_expr = build_binary_op (code, gnu_type, lhs, rhs); + + /* 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)) + return gnu_expr; + rhs_lt_zero = tree_expr_nonnegative_p (rhs) ? boolean_false_node : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero); @@ -8284,7 +8187,7 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, if (!TREE_CONSTANT (rhs)) { /* Even for add/subtract double size to get another base type. */ - int needed_precision = precision * 2; + const unsigned int needed_precision = precision * 2; if (code == MULT_EXPR && precision == 64) { @@ -8295,49 +8198,45 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, convert (int_64, rhs))); } - else if (needed_precision <= BITS_PER_WORD - || (code == MULT_EXPR - && needed_precision <= LONG_LONG_TYPE_SIZE)) + 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)); - tree check = build_binary_op + 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))); - tree result = convert (gnu_type, wide_result); - return - emit_check (check, result, CE_Overflow_Check_Failed, gnat_node); + emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node); } - else if (code == PLUS_EXPR || code == MINUS_EXPR) + if (code == PLUS_EXPR || code == MINUS_EXPR) { tree unsigned_type = gnat_type_for_size (precision, 1); - tree wrapped_expr = convert - (gnu_type, build_binary_op (code, unsigned_type, + tree wrapped_expr + = convert (gnu_type, + build_binary_op (code, unsigned_type, convert (unsigned_type, lhs), convert (unsigned_type, rhs))); - tree result = convert - (gnu_type, build_binary_op (code, gnu_type, lhs, rhs)); - /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */ - tree 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)); + 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, result, CE_Overflow_Check_Failed, gnat_node); + emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node); } } @@ -8411,13 +8310,6 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left, gcc_unreachable(); } - gnu_expr = build_binary_op (code, gnu_type, lhs, rhs); - - /* 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)) - return gnu_expr; - check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg, check_pos); @@ -8561,11 +8453,12 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, tree gnu_base_type = get_base_type (gnu_type); tree gnu_result = gnu_expr; - /* If we are not doing any checks, the output is an integral type, and - the input is not a floating type, just do the conversion. This - shortcut is required to avoid problems with packed array types - and simplifies code in all cases anyway. */ - if (!rangep && !overflowp && INTEGRAL_TYPE_P (gnu_base_type) + /* If we are not doing any checks, the output is an integral type and the + input is not a floating-point type, just do the conversion. This is + required for packed array types and is simpler in all cases anyway. */ + if (!rangep + && !overflowp + && INTEGRAL_TYPE_P (gnu_base_type) && !FLOAT_TYPE_P (gnu_in_type)) return convert (gnu_type, gnu_expr); @@ -8650,7 +8543,8 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, /* Now convert to the result base type. If this is a non-truncating float-to-integer conversion, round. */ - if (INTEGRAL_TYPE_P (gnu_base_type) && FLOAT_TYPE_P (gnu_in_basetype) + if (INTEGRAL_TYPE_P (gnu_base_type) + && FLOAT_TYPE_P (gnu_in_basetype) && !truncatep) { REAL_VALUE_TYPE half_minus_pred_half, pred_half; @@ -8659,15 +8553,11 @@ convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflowp, const struct real_format *fmt; /* The following calculations depend on proper rounding to even - of each arithmetic operation. In order to prevent excess + of each arithmetic operation. In order to prevent excess precision from spoiling this property, use the widest hardware floating-point type if FP_ARITH_MAY_WIDEN is true. */ calc_type - = FP_ARITH_MAY_WIDEN ? longest_float_type_node : gnu_in_basetype; - - /* FIXME: Should not have padding in the first place. */ - if (TYPE_IS_PADDING_P (calc_type)) - calc_type = TREE_TYPE (TYPE_FIELDS (calc_type)); + = fp_arith_may_widen ? longest_float_type_node : gnu_in_basetype; /* Compute the exact value calc_type'Pred (0.5) at compile time. */ fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type)); @@ -9301,6 +9191,7 @@ set_gnu_expr_location_from_node (tree node, Node_Id gnat_node) { CASE_CONVERT: case NON_LVALUE_EXPR: + case SAVE_EXPR: break; case COMPOUND_EXPR: diff --git a/main/gcc/ada/gcc-interface/utils.c b/main/gcc/ada/gcc-interface/utils.c index 022bca7fead..9f81eae8157 100644 --- a/main/gcc/ada/gcc-interface/utils.c +++ b/main/gcc/ada/gcc-interface/utils.c @@ -76,6 +76,9 @@ int double_float_alignment; is not specifically capped. */ int double_scalar_alignment; +/* True if floating-point arithmetics may use wider intermediate results. */ +bool fp_arith_may_widen = true; + /* Tree nodes for the various types and decls we create. */ tree gnat_std_decls[(int) ADT_LAST]; @@ -94,6 +97,7 @@ static tree handle_nonnull_attribute (tree *, tree, tree, int, bool *); static tree handle_sentinel_attribute (tree *, tree, tree, int, bool *); static tree handle_noreturn_attribute (tree *, tree, tree, int, bool *); static tree handle_leaf_attribute (tree *, tree, tree, int, bool *); +static tree handle_always_inline_attribute (tree *, tree, tree, int, bool *); static tree handle_malloc_attribute (tree *, tree, tree, int, bool *); static tree handle_type_generic_attribute (tree *, tree, tree, int, bool *); static tree handle_vector_size_attribute (tree *, tree, tree, int, bool *); @@ -125,6 +129,8 @@ const struct attribute_spec gnat_internal_attribute_table[] = false }, { "leaf", 0, 0, true, false, false, handle_leaf_attribute, false }, + { "always_inline",0, 0, true, false, false, handle_always_inline_attribute, + false }, { "malloc", 0, 0, true, false, false, handle_malloc_attribute, false }, { "type generic", 0, 0, false, true, true, handle_type_generic_attribute, @@ -238,6 +244,32 @@ static tree float_type_for_precision (int, enum machine_mode); 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. */ +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 types; /* A list of ..._TYPE nodes to propagate the + context to. */ + struct deferred_decl_context_node *next; /* The next queue item. */ +}; + +static struct deferred_decl_context_node *deferred_decl_context_queue = NULL; + +/* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to + feed it with the elaboration of GNAT_SCOPE. */ +static struct deferred_decl_context_node * +add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global); + +/* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to + feed it with the DECL_CONTEXT computed as part of N as soon as it is + computed. */ +static void add_deferred_type_context (struct deferred_decl_context_node *n, + tree type); /* Initialize data structures of the utils.c module. */ @@ -322,35 +354,31 @@ present_gnu_tree (Entity_Id gnat_entity) tree make_dummy_type (Entity_Id gnat_type) { - Entity_Id gnat_underlying = Gigi_Equivalent_Type (gnat_type); + Entity_Id gnat_equiv = Gigi_Equivalent_Type (Underlying_Type (gnat_type)); tree gnu_type; - /* If there is an equivalent type, get its underlying type. */ - if (Present (gnat_underlying)) - gnat_underlying = Gigi_Equivalent_Type (Underlying_Type (gnat_underlying)); - /* If there was no equivalent type (can only happen when just annotating types) or underlying type, go back to the original type. */ - if (No (gnat_underlying)) - gnat_underlying = gnat_type; + if (No (gnat_equiv)) + gnat_equiv = gnat_type; /* If it there already a dummy type, use that one. Else make one. */ - if (PRESENT_DUMMY_NODE (gnat_underlying)) - return GET_DUMMY_NODE (gnat_underlying); + if (PRESENT_DUMMY_NODE (gnat_equiv)) + return GET_DUMMY_NODE (gnat_equiv); /* If this is a record, make a RECORD_TYPE or UNION_TYPE; else make an ENUMERAL_TYPE. */ - gnu_type = make_node (Is_Record_Type (gnat_underlying) - ? tree_code_for_record_type (gnat_underlying) + gnu_type = make_node (Is_Record_Type (gnat_equiv) + ? tree_code_for_record_type (gnat_equiv) : ENUMERAL_TYPE); TYPE_NAME (gnu_type) = get_entity_name (gnat_type); TYPE_DUMMY_P (gnu_type) = 1; TYPE_STUB_DECL (gnu_type) = create_type_stub_decl (TYPE_NAME (gnu_type), gnu_type); - if (Is_By_Reference_Type (gnat_underlying)) + if (Is_By_Reference_Type (gnat_equiv)) TYPE_BY_REFERENCE_P (gnu_type) = 1; - SET_DUMMY_NODE (gnat_underlying, gnu_type); + SET_DUMMY_NODE (gnat_equiv, gnu_type); return gnu_type; } @@ -547,40 +575,159 @@ gnat_set_type_context (tree type, tree context) while (decl && DECL_PARALLEL_TYPE (decl)) { - TYPE_CONTEXT (DECL_PARALLEL_TYPE (decl)) = context; + tree parallel_type = DECL_PARALLEL_TYPE (decl); + + /* Give a context to the parallel types and their stub decl, if any. + Some parallel types seems to be present in multiple parallel type + chains, so don't mess with their context if they already have one. */ + if (TYPE_CONTEXT (parallel_type) == NULL_TREE) + { + if (TYPE_STUB_DECL (parallel_type) != NULL_TREE) + DECL_CONTEXT (TYPE_STUB_DECL (parallel_type)) = context; + TYPE_CONTEXT (parallel_type) = context; + } + decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl)); } } +/* Return the innermost scope, starting at GNAT_NODE, we are be interested in + the debug info, or Empty if there is no such scope. If not NULL, set + IS_SUBPROGRAM to whether the returned entity is a subprogram. */ + +static Entity_Id +get_debug_scope (Node_Id gnat_node, bool *is_subprogram) +{ + Entity_Id gnat_entity; + + if (is_subprogram) + *is_subprogram = false; + + if (Nkind (gnat_node) == N_Defining_Identifier) + gnat_entity = Scope (gnat_node); + else + return Empty; + + while (Present (gnat_entity)) + { + switch (Ekind (gnat_entity)) + { + case E_Function: + case E_Procedure: + if (Present (Protected_Body_Subprogram (gnat_entity))) + gnat_entity = Protected_Body_Subprogram (gnat_entity); + + /* If the scope is a subprogram, then just rely on + current_function_decl, so that we don't have to defer + anything. This is needed because other places rely on the + validity of the DECL_CONTEXT attribute of FUNCTION_DECL nodes. */ + if (is_subprogram) + *is_subprogram = true; + return gnat_entity; + + case E_Record_Type: + case E_Record_Subtype: + return gnat_entity; + + default: + /* By default, we are not interested in this particular scope: go to + the outer one. */ + break; + } + gnat_entity = Scope (gnat_entity); + } + return Empty; +} + +/* If N is NULL, set TYPE's context to CONTEXT. Defer this to the processing of + N otherwise. */ + +static void +defer_or_set_type_context (tree type, + tree context, + struct deferred_decl_context_node *n) +{ + if (n) + add_deferred_type_context (n, type); + else + gnat_set_type_context (type, context); +} + +/* Return global_context. Create it if needed, first. */ + +static tree +get_global_context (void) +{ + if (!global_context) + global_context = build_translation_unit_decl (NULL_TREE); + return global_context; +} + /* Record DECL as belonging to the current lexical scope and use GNAT_NODE for location information and flag propagation. */ void gnat_pushdecl (tree decl, Node_Id gnat_node) { - /* If DECL is public external or at top level, it has global context. */ - if ((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || global_bindings_p ()) - { - if (!global_context) - global_context = build_translation_unit_decl (NULL_TREE); - DECL_CONTEXT (decl) = global_context; - } - else + tree context = NULL_TREE; + struct deferred_decl_context_node *deferred_decl_context = NULL; + + /* If explicitely asked to make DECL global or if it's an imported nested + object, short-circuit the regular Scope-based context computation. */ + if (!((TREE_PUBLIC (decl) && DECL_EXTERNAL (decl)) || force_global == 1)) { - DECL_CONTEXT (decl) = current_function_decl; - - /* Functions imported in another function are not really nested. - For really nested functions mark them initially as needing - a static chain for uses of that flag before unnesting; - lower_nested_functions will then recompute it. */ - if (TREE_CODE (decl) == FUNCTION_DECL && !TREE_PUBLIC (decl)) - DECL_STATIC_CHAIN (decl) = 1; + /* Rely on the GNAT scope, or fallback to the current_function_decl if + the GNAT scope reached the global scope, if it reached a subprogram + or the declaration is a subprogram or a variable (for them we skip + intermediate context types because the subprogram body elaboration + machinery and the inliner both expect a subprogram context). + + Falling back to current_function_decl is necessary for implicit + subprograms created by gigi, such as the elaboration subprograms. */ + bool context_is_subprogram = false; + const Entity_Id gnat_scope + = get_debug_scope (gnat_node, &context_is_subprogram); + + if (Present (gnat_scope) + && !context_is_subprogram + && TREE_CODE (decl) != FUNCTION_DECL + && TREE_CODE (decl) != VAR_DECL) + /* Always assume the scope has not been elaborated, thus defer the + context propagation to the time its elaboration will be + available. */ + deferred_decl_context + = add_deferred_decl_context (decl, gnat_scope, force_global); + + /* External declarations (when force_global > 0) may not be in a + local context. */ + else if (current_function_decl != NULL_TREE && force_global == 0) + context = current_function_decl; } + /* If either we are forced to be in global mode or if both the GNAT scope and + the current_function_decl did not help determining the context, use the + global scope. */ + if (!deferred_decl_context && context == NULL_TREE) + context = get_global_context (); + + /* Functions imported in another function are not really nested. + For really nested functions mark them initially as needing + a static chain for uses of that flag before unnesting; + lower_nested_functions will then recompute it. */ + if (TREE_CODE (decl) == FUNCTION_DECL + && !TREE_PUBLIC (decl) + && context != NULL_TREE + && (TREE_CODE (context) == FUNCTION_DECL + || decl_function_context (context) != NULL_TREE)) + DECL_STATIC_CHAIN (decl) = 1; + + if (!deferred_decl_context) + DECL_CONTEXT (decl) = context; + TREE_NO_WARNING (decl) = (No (gnat_node) || Warnings_Off (gnat_node)); /* Set the location of DECL and emit a declaration for it. */ - if (Present (gnat_node)) + if (Present (gnat_node) && !renaming_from_generic_instantiation_p (gnat_node)) Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl)); add_decl_expr (decl, gnat_node); @@ -633,7 +780,9 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) if (TREE_CODE (t) == POINTER_TYPE) TYPE_NEXT_PTR_TO (t) = tt; TYPE_NAME (tt) = DECL_NAME (decl); - gnat_set_type_context (tt, DECL_CONTEXT (decl)); + defer_or_set_type_context (tt, + DECL_CONTEXT (decl), + deferred_decl_context); TYPE_STUB_DECL (tt) = TYPE_STUB_DECL (t); DECL_ORIGINAL_TYPE (decl) = tt; } @@ -643,7 +792,9 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) /* We need a variant for the placeholder machinery to work. */ tree tt = build_variant_type_copy (t); TYPE_NAME (tt) = decl; - gnat_set_type_context (tt, DECL_CONTEXT (decl)); + defer_or_set_type_context (tt, + DECL_CONTEXT (decl), + deferred_decl_context); TREE_USED (tt) = TREE_USED (t); TREE_TYPE (decl) = tt; if (DECL_ORIGINAL_TYPE (TYPE_NAME (t))) @@ -659,13 +810,17 @@ gnat_pushdecl (tree decl, Node_Id gnat_node) t = NULL_TREE; /* Propagate the name to all the anonymous variants. This is needed - for the type qualifiers machinery to work properly. */ + for the type qualifiers machinery to work properly. Also propagate + the context to them. Note that the context will be propagated to all + parallel types too thanks to gnat_set_type_context. */ if (t) for (t = TYPE_MAIN_VARIANT (t); t; t = TYPE_NEXT_VARIANT (t)) if (!(TYPE_NAME (t) && TREE_CODE (TYPE_NAME (t)) == TYPE_DECL)) { TYPE_NAME (t) = decl; - gnat_set_type_context (t, DECL_CONTEXT (decl)); + defer_or_set_type_context (t, + DECL_CONTEXT (decl), + deferred_decl_context); } } } @@ -948,12 +1103,8 @@ make_type_from_size (tree type, tree size_tree, bool for_biased) else new_type = make_signed_type (size); TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type; - SET_TYPE_RM_MIN_VALUE (new_type, - convert (TREE_TYPE (new_type), - TYPE_MIN_VALUE (type))); - SET_TYPE_RM_MAX_VALUE (new_type, - convert (TREE_TYPE (new_type), - TYPE_MAX_VALUE (type))); + SET_TYPE_RM_MIN_VALUE (new_type, TYPE_MIN_VALUE (type)); + SET_TYPE_RM_MAX_VALUE (new_type, TYPE_MAX_VALUE (type)); /* Copy the name to show that it's essentially the same type and not a subrange type. */ TYPE_NAME (new_type) = TYPE_NAME (type); @@ -1034,8 +1185,39 @@ pad_type_hash_eq (const void *p1, const void *p2) && TYPE_ADA_SIZE (type1) == TYPE_ADA_SIZE (type2); } +/* Look up the padded TYPE in the hash table and return its canonical version + if it exists; otherwise, insert it into the hash table. */ + +static tree +lookup_and_insert_pad_type (tree type) +{ + hashval_t hashcode; + struct pad_type_hash in, *h; + void **loc; + + hashcode + = iterative_hash_object (TYPE_HASH (TREE_TYPE (TYPE_FIELDS (type))), 0); + hashcode = iterative_hash_expr (TYPE_SIZE (type), hashcode); + hashcode = iterative_hash_hashval_t (TYPE_ALIGN (type), hashcode); + hashcode = iterative_hash_expr (TYPE_ADA_SIZE (type), hashcode); + + in.hash = hashcode; + in.type = type; + h = (struct pad_type_hash *) + htab_find_with_hash (pad_type_hash_table, &in, hashcode); + if (h) + return h->type; + + h = ggc_alloc (); + h->hash = hashcode; + h->type = type; + loc = htab_find_slot_with_hash (pad_type_hash_table, h, hashcode, INSERT); + *loc = (void *)h; + return NULL_TREE; +} + /* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type - if needed. We have already verified that SIZE and TYPE are large enough. + if needed. We have already verified that SIZE and ALIGN are large enough. GNAT_ENTITY is used to name the resulting record and to issue a warning. 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. @@ -1155,39 +1337,19 @@ maybe_pad_type (tree type, tree size, unsigned int align, /* Set the RM size if requested. */ if (set_rm_size) { + tree canonical_pad_type; + SET_TYPE_ADA_SIZE (record, size ? size : orig_size); /* If the padded type is complete and has constant size, we canonicalize it by means of the hash table. This is consistent with the language semantics and ensures that gigi and the middle-end have a common view of these padded types. */ - if (TREE_CONSTANT (TYPE_SIZE (record))) + if (TREE_CONSTANT (TYPE_SIZE (record)) + && (canonical_pad_type = lookup_and_insert_pad_type (record))) { - hashval_t hashcode; - struct pad_type_hash in, *h; - void **loc; - - hashcode = iterative_hash_object (TYPE_HASH (type), 0); - hashcode = iterative_hash_expr (TYPE_SIZE (record), hashcode); - hashcode = iterative_hash_hashval_t (TYPE_ALIGN (record), hashcode); - hashcode = iterative_hash_expr (TYPE_ADA_SIZE (record), hashcode); - - in.hash = hashcode; - in.type = record; - h = (struct pad_type_hash *) - htab_find_with_hash (pad_type_hash_table, &in, hashcode); - if (h) - { - record = h->type; - goto built; - } - - h = ggc_alloc (); - h->hash = hashcode; - h->type = record; - loc = htab_find_slot_with_hash (pad_type_hash_table, h, hashcode, - INSERT); - *loc = (void *)h; + record = canonical_pad_type; + goto built; } } @@ -1614,7 +1776,10 @@ finish_record_type (tree record_type, tree field_list, int rep_level, rest_of_record_type_compilation (record_type); } -/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. */ +/* Append PARALLEL_TYPE on the chain of parallel types of TYPE. If + PARRALEL_TYPE has no context and its computation is not deferred yet, also + propagate TYPE's context to PARALLEL_TYPE's or defer its propagation to the + moment TYPE will get a context. */ void add_parallel_type (tree type, tree parallel_type) @@ -1625,6 +1790,19 @@ add_parallel_type (tree type, tree parallel_type) decl = TYPE_STUB_DECL (DECL_PARALLEL_TYPE (decl)); SET_DECL_PARALLEL_TYPE (decl, parallel_type); + + /* If PARALLEL_TYPE already has a context, we are done. */ + if (TYPE_CONTEXT (parallel_type) != NULL_TREE) + return; + + /* Otherwise, try to get one from TYPE's context. */ + if (TYPE_CONTEXT (type) != NULL_TREE) + /* TYPE already has a context, so simply propagate it to PARALLEL_TYPE. */ + gnat_set_type_context (parallel_type, TYPE_CONTEXT (type)); + + /* ... otherwise TYPE has not context yet. We know it will thanks to + gnat_pushdecl, and then its context will be propagated to PARALLEL_TYPE. + So we have nothing to do in this case. */ } /* Return true if TYPE has a parallel type. */ @@ -2034,8 +2212,8 @@ create_range_type (tree type, tree min, tree max) TYPE_MAX_VALUE (type)); /* Then set the actual range. */ - SET_TYPE_RM_MIN_VALUE (range_type, convert (type, min)); - SET_TYPE_RM_MAX_VALUE (range_type, convert (type, max)); + SET_TYPE_RM_MIN_VALUE (range_type, min); + SET_TYPE_RM_MAX_VALUE (range_type, max); return range_type; } @@ -2550,6 +2728,177 @@ value_factor_p (tree value, HOST_WIDE_INT factor) return false; } +/* Return whether GNAT_NODE is a defining identifier for a renaming that comes + from the parameter association for the instantiation of a generic. We do + not want to emit source location for them: the code generated for their + initialization is likely to disturb debugging. */ + +bool +renaming_from_generic_instantiation_p (Node_Id gnat_node) +{ + if (Nkind (gnat_node) != N_Defining_Identifier + || !IN (Ekind (gnat_node), Object_Kind) + || Comes_From_Source (gnat_node) + || !Present (Renamed_Object (gnat_node))) + return false; + + /* Get the object declaration of the renamed object, if any and if the + renamed object is a mere identifier. */ + gnat_node = Renamed_Object (gnat_node); + if (Nkind (gnat_node) != N_Identifier) + return false; + + gnat_node = Entity (gnat_node); + if (!Present (Parent (gnat_node))) + return false; + + gnat_node = Parent (gnat_node); + return + (Present (gnat_node) + && Nkind (gnat_node) == N_Object_Declaration + && Present (Corresponding_Generic_Association (gnat_node))); +} + +/* Defer the initialization of DECL's DECL_CONTEXT attribute, scheduling to + feed it with the elaboration of GNAT_SCOPE. */ + +static struct deferred_decl_context_node * +add_deferred_decl_context (tree decl, Entity_Id gnat_scope, int force_global) +{ + struct deferred_decl_context_node *new_node; + + new_node + = (struct deferred_decl_context_node * ) xmalloc (sizeof (*new_node)); + new_node->decl = decl; + new_node->gnat_scope = gnat_scope; + new_node->force_global = force_global; + new_node->types.create (1); + new_node->next = deferred_decl_context_queue; + deferred_decl_context_queue = new_node; + return new_node; +} + +/* Defer the initialization of TYPE's TYPE_CONTEXT attribute, scheduling to + feed it with the DECL_CONTEXT computed as part of N as soon as it is + computed. */ + +static void +add_deferred_type_context (struct deferred_decl_context_node *n, tree type) +{ + n->types.safe_push (type); +} + +/* Get the GENERIC node corresponding to GNAT_SCOPE, if available. Return + NULL_TREE if it is not available. */ + +static tree +compute_deferred_decl_context (Entity_Id gnat_scope) +{ + tree context; + + if (present_gnu_tree (gnat_scope)) + context = get_gnu_tree (gnat_scope); + else + return NULL_TREE; + + if (TREE_CODE (context) == TYPE_DECL) + { + const tree context_type = TREE_TYPE (context); + + /* Skip dummy types: only the final ones can appear in the context + chain. */ + if (TYPE_DUMMY_P (context_type)) + return NULL_TREE; + + /* ..._TYPE nodes are more useful than TYPE_DECL nodes in the context + chain. */ + else + context = context_type; + } + + return context; +} + +/* Try to process all deferred nodes in the queue. Keep in the queue the ones + that cannot be processed yet, remove the other ones. If FORCE is true, + force the processing for all nodes, use the global context when nodes don't + have a GNU translation. */ + +void +process_deferred_decl_context (bool force) +{ + struct deferred_decl_context_node **it = &deferred_decl_context_queue; + struct deferred_decl_context_node *node; + + while (*it != NULL) + { + bool processed = false; + tree context = NULL_TREE; + Entity_Id gnat_scope; + + node = *it; + + /* If FORCE, get the innermost elaborated scope. Otherwise, just try to + get the first scope. */ + gnat_scope = node->gnat_scope; + while (Present (gnat_scope)) + { + context = compute_deferred_decl_context (gnat_scope); + if (!force || context != NULL_TREE) + break; + gnat_scope = get_debug_scope (gnat_scope, NULL); + } + + /* Imported declarations must not be in a local context (i.e. not inside + a function). */ + if (context != NULL_TREE && node->force_global > 0) + { + tree ctx = context; + + while (ctx != NULL_TREE) + { + gcc_assert (TREE_CODE (ctx) != FUNCTION_DECL); + ctx = (DECL_P (ctx)) + ? DECL_CONTEXT (ctx) + : TYPE_CONTEXT (ctx); + } + } + + /* If FORCE, we want to get rid of all nodes in the queue: in case there + was no elaborated scope, use the global context. */ + if (force && context == NULL_TREE) + context = get_global_context (); + + if (context != NULL_TREE) + { + tree t; + int i; + + DECL_CONTEXT (node->decl) = context; + + /* Propagate it to the TYPE_CONTEXT attributes of the requested + ..._TYPE nodes. */ + FOR_EACH_VEC_ELT (node->types, i, t) + { + gnat_set_type_context (t, context); + } + processed = true; + } + + /* If this node has been successfuly processed, remove it from the + queue. Then move to the next node. */ + if (processed) + { + *it = node->next; + node->types.release (); + free (node); + } + else + it = &node->next; + } +} + + /* Return VALUE scaled by the biggest power-of-2 factor of EXPR. */ static unsigned int @@ -2684,6 +3033,15 @@ create_subprog_decl (tree subprog_name, tree asm_name, tree subprog_type, case is_disabled: break; + case is_required: + if (Back_End_Inlining) + decl_attributes (&subprog_decl, + tree_cons (get_identifier ("always_inline"), + NULL_TREE, NULL_TREE), + ATTR_FLAG_TYPE_IN_PLACE); + + /* ... fall through ... */ + case is_enabled: DECL_DECLARED_INLINE_P (subprog_decl) = 1; DECL_NO_INLINE_WARNING_P (subprog_decl) = artificial_flag; @@ -2802,7 +3160,7 @@ rest_of_subprog_body_compilation (tree subprog_decl) else /* Register this function with cgraph just far enough to get it added to our parent's nested function list. */ - (void) cgraph_get_create_node (subprog_decl); + (void) cgraph_node::get_create (subprog_decl); } tree @@ -3052,12 +3410,14 @@ max_size (tree exp, bool max_p) case tcc_reference: /* If this contains a PLACEHOLDER_EXPR, it is the thing we want to modify. Otherwise, we treat it like a variable. */ - if (!CONTAINS_PLACEHOLDER_P (exp)) - return exp; + if (CONTAINS_PLACEHOLDER_P (exp)) + { + 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); + } - type = TREE_TYPE (TREE_OPERAND (exp, 1)); - return - max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true); + return exp; case tcc_comparison: return max_p ? size_one_node : size_zero_node; @@ -3287,962 +3647,6 @@ build_vector_type_for_array (tree array_type, tree attribute) return vector_type; } -/* Helper routine to make a descriptor field. FIELD_LIST is the list of decls - being built; the new decl is chained on to the front of the list. */ - -static tree -make_descriptor_field (const char *name, tree type, tree rec_type, - tree initial, tree field_list) -{ - tree field - = create_field_decl (get_identifier (name), type, rec_type, NULL_TREE, - NULL_TREE, 0, 0); - - DECL_INITIAL (field) = initial; - DECL_CHAIN (field) = field_list; - return field; -} - -/* Build a 32-bit VMS descriptor from a Mechanism_Type, which must specify a - descriptor type, and the GCC type of an object. Each FIELD_DECL in the - type contains in its DECL_INITIAL the expression to use when a constructor - is made for the type. GNAT_ENTITY is an entity used to print out an error - message if the mechanism cannot be applied to an object of that type and - also for the name. */ - -tree -build_vms_descriptor32 (tree type, Mechanism_Type mech, Entity_Id gnat_entity) -{ - tree record_type = make_node (RECORD_TYPE); - tree pointer32_type, pointer64_type; - tree field_list = NULL_TREE; - int klass, ndim, i, dtype = 0; - tree inner_type, tem; - tree *idx_arr; - - /* If TYPE is an unconstrained array, use the underlying array type. */ - if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); - - /* If this is an array, compute the number of dimensions in the array, - get the index types, and point to the inner type. */ - if (TREE_CODE (type) != ARRAY_TYPE) - ndim = 0; - else - for (ndim = 1, inner_type = type; - TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); - ndim++, inner_type = TREE_TYPE (inner_type)) - ; - - idx_arr = XALLOCAVEC (tree, ndim); - - if (mech != By_Descriptor_NCA && mech != By_Short_Descriptor_NCA - && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) - for (i = ndim - 1, inner_type = type; - i >= 0; - i--, inner_type = TREE_TYPE (inner_type)) - idx_arr[i] = TYPE_DOMAIN (inner_type); - else - for (i = 0, inner_type = type; - i < ndim; - i++, inner_type = TREE_TYPE (inner_type)) - idx_arr[i] = TYPE_DOMAIN (inner_type); - - /* Now get the DTYPE value. */ - switch (TREE_CODE (type)) - { - case INTEGER_TYPE: - case ENUMERAL_TYPE: - case BOOLEAN_TYPE: - if (TYPE_VAX_FLOATING_POINT_P (type)) - switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type))) - { - case 6: - dtype = 10; - break; - case 9: - dtype = 11; - break; - case 15: - dtype = 27; - break; - } - else - switch (GET_MODE_BITSIZE (TYPE_MODE (type))) - { - case 8: - dtype = TYPE_UNSIGNED (type) ? 2 : 6; - break; - case 16: - dtype = TYPE_UNSIGNED (type) ? 3 : 7; - break; - case 32: - dtype = TYPE_UNSIGNED (type) ? 4 : 8; - break; - case 64: - dtype = TYPE_UNSIGNED (type) ? 5 : 9; - break; - case 128: - dtype = TYPE_UNSIGNED (type) ? 25 : 26; - break; - } - break; - - case REAL_TYPE: - dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; - break; - - case COMPLEX_TYPE: - if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE - && TYPE_VAX_FLOATING_POINT_P (type)) - switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type))) - { - case 6: - dtype = 12; - break; - case 9: - dtype = 13; - break; - case 15: - dtype = 29; - } - else - dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; - break; - - case ARRAY_TYPE: - dtype = 14; - break; - - default: - break; - } - - /* Get the CLASS value. */ - switch (mech) - { - case By_Descriptor_A: - case By_Short_Descriptor_A: - klass = 4; - break; - case By_Descriptor_NCA: - case By_Short_Descriptor_NCA: - klass = 10; - break; - case By_Descriptor_SB: - case By_Short_Descriptor_SB: - klass = 15; - break; - case By_Descriptor: - case By_Short_Descriptor: - case By_Descriptor_S: - case By_Short_Descriptor_S: - default: - klass = 1; - break; - } - - /* Make the type for a descriptor for VMS. The first four fields are the - same for all types. */ - field_list - = make_descriptor_field ("LENGTH", gnat_type_for_size (16, 1), record_type, - size_in_bytes ((mech == By_Descriptor_A - || mech == By_Short_Descriptor_A) - ? inner_type : type), - field_list); - field_list - = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), record_type, - size_int (dtype), field_list); - field_list - = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), record_type, - size_int (klass), field_list); - - pointer32_type = build_pointer_type_for_mode (type, SImode, false); - pointer64_type = build_pointer_type_for_mode (type, DImode, false); - - /* Ensure that only 32-bit pointers are passed in 32-bit descriptors. Note - that we cannot build a template call to the CE routine as it would get a - wrong source location; instead we use a second placeholder for it. */ - tem = build_unary_op (ADDR_EXPR, pointer64_type, - build0 (PLACEHOLDER_EXPR, type)); - tem = build3 (COND_EXPR, pointer32_type, - Pmode != SImode - ? build_binary_op (GE_EXPR, boolean_type_node, tem, - build_int_cstu (pointer64_type, 0x80000000)) - : boolean_false_node, - build0 (PLACEHOLDER_EXPR, void_type_node), - convert (pointer32_type, tem)); - - field_list - = make_descriptor_field ("POINTER", pointer32_type, record_type, tem, - field_list); - - switch (mech) - { - case By_Descriptor: - case By_Short_Descriptor: - case By_Descriptor_S: - case By_Short_Descriptor_S: - break; - - case By_Descriptor_SB: - case By_Short_Descriptor_SB: - field_list - = make_descriptor_field ("SB_L1", gnat_type_for_size (32, 1), - record_type, - (TREE_CODE (type) == ARRAY_TYPE - ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) - : size_zero_node), - field_list); - field_list - = make_descriptor_field ("SB_U1", gnat_type_for_size (32, 1), - record_type, - (TREE_CODE (type) == ARRAY_TYPE - ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) - : size_zero_node), - field_list); - break; - - case By_Descriptor_A: - case By_Short_Descriptor_A: - case By_Descriptor_NCA: - case By_Short_Descriptor_NCA: - field_list - = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1), - record_type, size_zero_node, field_list); - - field_list - = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1), - record_type, size_zero_node, field_list); - - field_list - = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1), - record_type, - size_int ((mech == By_Descriptor_NCA - || mech == By_Short_Descriptor_NCA) - ? 0 - /* Set FL_COLUMN, FL_COEFF, and - FL_BOUNDS. */ - : (TREE_CODE (type) == ARRAY_TYPE - && TYPE_CONVENTION_FORTRAN_P - (type) - ? 224 : 192)), - field_list); - - field_list - = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1), - record_type, size_int (ndim), field_list); - - field_list - = make_descriptor_field ("ARSIZE", gnat_type_for_size (32, 1), - record_type, size_in_bytes (type), - field_list); - - /* Now build a pointer to the 0,0,0... element. */ - tem = build0 (PLACEHOLDER_EXPR, type); - for (i = 0, inner_type = type; i < ndim; - i++, inner_type = TREE_TYPE (inner_type)) - tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, - convert (TYPE_DOMAIN (inner_type), size_zero_node), - NULL_TREE, NULL_TREE); - - field_list - = make_descriptor_field ("A0", pointer32_type, record_type, - build1 (ADDR_EXPR, pointer32_type, tem), - field_list); - - /* Next come the addressing coefficients. */ - tem = size_one_node; - for (i = 0; i < ndim; i++) - { - char fname[3]; - tree idx_length - = size_binop (MULT_EXPR, tem, - size_binop (PLUS_EXPR, - size_binop (MINUS_EXPR, - TYPE_MAX_VALUE (idx_arr[i]), - TYPE_MIN_VALUE (idx_arr[i])), - size_int (1))); - - fname[0] = ((mech == By_Descriptor_NCA || - mech == By_Short_Descriptor_NCA) ? 'S' : 'M'); - fname[1] = '0' + i, fname[2] = 0; - field_list - = make_descriptor_field (fname, gnat_type_for_size (32, 1), - record_type, idx_length, field_list); - - if (mech == By_Descriptor_NCA || mech == By_Short_Descriptor_NCA) - tem = idx_length; - } - - /* Finally here are the bounds. */ - for (i = 0; i < ndim; i++) - { - char fname[3]; - - fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; - field_list - = make_descriptor_field (fname, gnat_type_for_size (32, 1), - record_type, TYPE_MIN_VALUE (idx_arr[i]), - field_list); - - fname[0] = 'U'; - field_list - = make_descriptor_field (fname, gnat_type_for_size (32, 1), - record_type, TYPE_MAX_VALUE (idx_arr[i]), - field_list); - } - break; - - default: - post_error ("unsupported descriptor type for &", gnat_entity); - } - - TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC"); - finish_record_type (record_type, nreverse (field_list), 0, false); - return record_type; -} - -/* Build a 64-bit VMS descriptor from a Mechanism_Type, which must specify a - descriptor type, and the GCC type of an object. Each FIELD_DECL in the - type contains in its DECL_INITIAL the expression to use when a constructor - is made for the type. GNAT_ENTITY is an entity used to print out an error - message if the mechanism cannot be applied to an object of that type and - also for the name. */ - -tree -build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity) -{ - tree record_type = make_node (RECORD_TYPE); - tree pointer64_type; - tree field_list = NULL_TREE; - int klass, ndim, i, dtype = 0; - tree inner_type, tem; - tree *idx_arr; - - /* If TYPE is an unconstrained array, use the underlying array type. */ - if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE) - type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))); - - /* If this is an array, compute the number of dimensions in the array, - get the index types, and point to the inner type. */ - if (TREE_CODE (type) != ARRAY_TYPE) - ndim = 0; - else - for (ndim = 1, inner_type = type; - TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE - && TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type)); - ndim++, inner_type = TREE_TYPE (inner_type)) - ; - - idx_arr = XALLOCAVEC (tree, ndim); - - if (mech != By_Descriptor_NCA - && TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type)) - for (i = ndim - 1, inner_type = type; - i >= 0; - i--, inner_type = TREE_TYPE (inner_type)) - idx_arr[i] = TYPE_DOMAIN (inner_type); - else - for (i = 0, inner_type = type; - i < ndim; - i++, inner_type = TREE_TYPE (inner_type)) - idx_arr[i] = TYPE_DOMAIN (inner_type); - - /* Now get the DTYPE value. */ - switch (TREE_CODE (type)) - { - case INTEGER_TYPE: - case ENUMERAL_TYPE: - case BOOLEAN_TYPE: - if (TYPE_VAX_FLOATING_POINT_P (type)) - switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type))) - { - case 6: - dtype = 10; - break; - case 9: - dtype = 11; - break; - case 15: - dtype = 27; - break; - } - else - switch (GET_MODE_BITSIZE (TYPE_MODE (type))) - { - case 8: - dtype = TYPE_UNSIGNED (type) ? 2 : 6; - break; - case 16: - dtype = TYPE_UNSIGNED (type) ? 3 : 7; - break; - case 32: - dtype = TYPE_UNSIGNED (type) ? 4 : 8; - break; - case 64: - dtype = TYPE_UNSIGNED (type) ? 5 : 9; - break; - case 128: - dtype = TYPE_UNSIGNED (type) ? 25 : 26; - break; - } - break; - - case REAL_TYPE: - dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53; - break; - - case COMPLEX_TYPE: - if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE - && TYPE_VAX_FLOATING_POINT_P (type)) - switch (tree_to_uhwi (TYPE_DIGITS_VALUE (type))) - { - case 6: - dtype = 12; - break; - case 9: - dtype = 13; - break; - case 15: - dtype = 29; - } - else - dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55; - break; - - case ARRAY_TYPE: - dtype = 14; - break; - - default: - break; - } - - /* Get the CLASS value. */ - switch (mech) - { - case By_Descriptor_A: - klass = 4; - break; - case By_Descriptor_NCA: - klass = 10; - break; - case By_Descriptor_SB: - klass = 15; - break; - case By_Descriptor: - case By_Descriptor_S: - default: - klass = 1; - break; - } - - /* Make the type for a 64-bit descriptor for VMS. The first six fields - are the same for all types. */ - field_list - = make_descriptor_field ("MBO", gnat_type_for_size (16, 1), - record_type, size_int (1), field_list); - field_list - = make_descriptor_field ("DTYPE", gnat_type_for_size (8, 1), - record_type, size_int (dtype), field_list); - field_list - = make_descriptor_field ("CLASS", gnat_type_for_size (8, 1), - record_type, size_int (klass), field_list); - field_list - = make_descriptor_field ("MBMO", gnat_type_for_size (32, 1), - record_type, size_int (-1), field_list); - field_list - = make_descriptor_field ("LENGTH", gnat_type_for_size (64, 1), - record_type, - size_in_bytes (mech == By_Descriptor_A - ? inner_type : type), - field_list); - - pointer64_type = build_pointer_type_for_mode (type, DImode, false); - - field_list - = make_descriptor_field ("POINTER", pointer64_type, record_type, - build_unary_op (ADDR_EXPR, pointer64_type, - build0 (PLACEHOLDER_EXPR, type)), - field_list); - - switch (mech) - { - case By_Descriptor: - case By_Descriptor_S: - break; - - case By_Descriptor_SB: - field_list - = make_descriptor_field ("SB_L1", gnat_type_for_size (64, 1), - record_type, - (TREE_CODE (type) == ARRAY_TYPE - ? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) - : size_zero_node), - field_list); - field_list - = make_descriptor_field ("SB_U1", gnat_type_for_size (64, 1), - record_type, - (TREE_CODE (type) == ARRAY_TYPE - ? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) - : size_zero_node), - field_list); - break; - - case By_Descriptor_A: - case By_Descriptor_NCA: - field_list - = make_descriptor_field ("SCALE", gnat_type_for_size (8, 1), - record_type, size_zero_node, field_list); - - field_list - = make_descriptor_field ("DIGITS", gnat_type_for_size (8, 1), - record_type, size_zero_node, field_list); - - dtype = (mech == By_Descriptor_NCA - ? 0 - /* Set FL_COLUMN, FL_COEFF, and - FL_BOUNDS. */ - : (TREE_CODE (type) == ARRAY_TYPE - && TYPE_CONVENTION_FORTRAN_P (type) - ? 224 : 192)); - field_list - = make_descriptor_field ("AFLAGS", gnat_type_for_size (8, 1), - record_type, size_int (dtype), - field_list); - - field_list - = make_descriptor_field ("DIMCT", gnat_type_for_size (8, 1), - record_type, size_int (ndim), field_list); - - field_list - = make_descriptor_field ("MBZ", gnat_type_for_size (32, 1), - record_type, size_int (0), field_list); - field_list - = make_descriptor_field ("ARSIZE", gnat_type_for_size (64, 1), - record_type, size_in_bytes (type), - field_list); - - /* Now build a pointer to the 0,0,0... element. */ - tem = build0 (PLACEHOLDER_EXPR, type); - for (i = 0, inner_type = type; i < ndim; - i++, inner_type = TREE_TYPE (inner_type)) - tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem, - convert (TYPE_DOMAIN (inner_type), size_zero_node), - NULL_TREE, NULL_TREE); - - field_list - = make_descriptor_field ("A0", pointer64_type, record_type, - build1 (ADDR_EXPR, pointer64_type, tem), - field_list); - - /* Next come the addressing coefficients. */ - tem = size_one_node; - for (i = 0; i < ndim; i++) - { - char fname[3]; - tree idx_length - = size_binop (MULT_EXPR, tem, - size_binop (PLUS_EXPR, - size_binop (MINUS_EXPR, - TYPE_MAX_VALUE (idx_arr[i]), - TYPE_MIN_VALUE (idx_arr[i])), - size_int (1))); - - fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M'); - fname[1] = '0' + i, fname[2] = 0; - field_list - = make_descriptor_field (fname, gnat_type_for_size (64, 1), - record_type, idx_length, field_list); - - if (mech == By_Descriptor_NCA) - tem = idx_length; - } - - /* Finally here are the bounds. */ - for (i = 0; i < ndim; i++) - { - char fname[3]; - - fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0; - field_list - = make_descriptor_field (fname, gnat_type_for_size (64, 1), - record_type, - TYPE_MIN_VALUE (idx_arr[i]), field_list); - - fname[0] = 'U'; - field_list - = make_descriptor_field (fname, gnat_type_for_size (64, 1), - record_type, - TYPE_MAX_VALUE (idx_arr[i]), field_list); - } - break; - - default: - post_error ("unsupported descriptor type for &", gnat_entity); - } - - TYPE_NAME (record_type) = create_concat_name (gnat_entity, "DESC64"); - finish_record_type (record_type, nreverse (field_list), 0, false); - return record_type; -} - -/* Fill in a VMS descriptor of GNU_TYPE for GNU_EXPR and return the result. - GNAT_ACTUAL is the actual parameter for which the descriptor is built. */ - -tree -fill_vms_descriptor (tree gnu_type, tree gnu_expr, Node_Id gnat_actual) -{ - vec *v = NULL; - tree field; - - gnu_expr = maybe_unconstrained_array (gnu_expr); - gnu_expr = gnat_protect_expr (gnu_expr); - gnat_mark_addressable (gnu_expr); - - /* We may need to substitute both GNU_EXPR and a CALL_EXPR to the raise CE - routine in case we have a 32-bit descriptor. */ - gnu_expr = build2 (COMPOUND_EXPR, void_type_node, - build_call_raise (CE_Range_Check_Failed, gnat_actual, - N_Raise_Constraint_Error), - gnu_expr); - - for (field = TYPE_FIELDS (gnu_type); field; field = DECL_CHAIN (field)) - { - tree value - = convert (TREE_TYPE (field), - SUBSTITUTE_PLACEHOLDER_IN_EXPR (DECL_INITIAL (field), - gnu_expr)); - CONSTRUCTOR_APPEND_ELT (v, field, value); - } - - return gnat_build_constructor (gnu_type, v); -} - -/* Convert GNU_EXPR, a pointer to a 64bit VMS descriptor, to GNU_TYPE, a - regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to - which the VMS descriptor is passed. */ - -static tree -convert_vms_descriptor64 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) -{ - tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); - tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); - /* The CLASS field is the 3rd field in the descriptor. */ - tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type))); - /* The POINTER field is the 6th field in the descriptor. */ - tree pointer = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (klass))); - - /* Retrieve the value of the POINTER field. */ - tree gnu_expr64 - = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); - - if (POINTER_TYPE_P (gnu_type)) - return convert (gnu_type, gnu_expr64); - - else if (TYPE_IS_FAT_POINTER_P (gnu_type)) - { - tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); - tree p_bounds_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))); - tree template_type = TREE_TYPE (p_bounds_type); - tree min_field = TYPE_FIELDS (template_type); - tree max_field = DECL_CHAIN (TYPE_FIELDS (template_type)); - tree template_tree, template_addr, aflags, dimct, t, u; - /* See the head comment of build_vms_descriptor. */ - int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); - tree lfield, ufield; - vec *v; - - /* Convert POINTER to the pointer-to-array type. */ - gnu_expr64 = convert (p_array_type, gnu_expr64); - - switch (iklass) - { - case 1: /* Class S */ - case 15: /* Class SB */ - /* Build {1, LENGTH} template; LENGTH64 is the 5th field. */ - vec_alloc (v, 2); - t = DECL_CHAIN (DECL_CHAIN (klass)); - t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - CONSTRUCTOR_APPEND_ELT (v, min_field, - convert (TREE_TYPE (min_field), - integer_one_node)); - CONSTRUCTOR_APPEND_ELT (v, max_field, - convert (TREE_TYPE (max_field), t)); - template_tree = gnat_build_constructor (template_type, v); - template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); - - /* For class S, we are done. */ - if (iklass == 1) - break; - - /* Test that we really have a SB descriptor, like DEC Ada. */ - t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL); - u = convert (TREE_TYPE (klass), DECL_INITIAL (klass)); - u = build_binary_op (EQ_EXPR, boolean_type_node, t, u); - /* If so, there is already a template in the descriptor and - it is located right after the POINTER field. The fields are - 64bits so they must be repacked. */ - t = DECL_CHAIN (pointer); - lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); - - t = DECL_CHAIN (t); - ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - ufield = convert - (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield); - - /* Build the template in the form of a constructor. */ - vec_alloc (v, 2); - CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); - CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)), - ufield); - template_tree = gnat_build_constructor (template_type, v); - - /* Otherwise use the {1, LENGTH} template we build above. */ - template_addr = build3 (COND_EXPR, p_bounds_type, u, - build_unary_op (ADDR_EXPR, p_bounds_type, - template_tree), - template_addr); - break; - - case 4: /* Class A */ - /* The AFLAGS field is the 3rd field after the pointer in the - descriptor. */ - t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer))); - aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* The DIMCT field is the next field in the descriptor after - aflags. */ - t = DECL_CHAIN (t); - dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* Raise CONSTRAINT_ERROR if either more than 1 dimension - or FL_COEFF or FL_BOUNDS not set. */ - u = build_int_cst (TREE_TYPE (aflags), 192); - u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node, - build_binary_op (NE_EXPR, boolean_type_node, - dimct, - convert (TREE_TYPE (dimct), - size_one_node)), - build_binary_op (NE_EXPR, boolean_type_node, - build2 (BIT_AND_EXPR, - TREE_TYPE (aflags), - aflags, u), - u)); - /* There is already a template in the descriptor and it is located - in block 3. The fields are 64bits so they must be repacked. */ - t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN - (t))))); - lfield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - lfield = convert (TREE_TYPE (TYPE_FIELDS (template_type)), lfield); - - t = DECL_CHAIN (t); - ufield = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - ufield = convert - (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (template_type))), ufield); - - /* Build the template in the form of a constructor. */ - vec_alloc (v, 2); - CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (template_type), lfield); - CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (template_type)), - ufield); - template_tree = gnat_build_constructor (template_type, v); - template_tree = build3 (COND_EXPR, template_type, u, - build_call_raise (CE_Length_Check_Failed, Empty, - N_Raise_Constraint_Error), - template_tree); - template_addr - = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree); - break; - - case 10: /* Class NCA */ - default: - post_error ("unsupported descriptor type for &", gnat_subprog); - template_addr = integer_zero_node; - break; - } - - /* Build the fat pointer in the form of a constructor. */ - vec_alloc (v, 2); - CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr64); - CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr); - return gnat_build_constructor (gnu_type, v); - } - - else - gcc_unreachable (); -} - -/* Convert GNU_EXPR, a pointer to a 32bit VMS descriptor, to GNU_TYPE, a - regular pointer or fat pointer type. GNAT_SUBPROG is the subprogram to - which the VMS descriptor is passed. */ - -static tree -convert_vms_descriptor32 (tree gnu_type, tree gnu_expr, Entity_Id gnat_subprog) -{ - tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); - tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); - /* The CLASS field is the 3rd field in the descriptor. */ - tree klass = DECL_CHAIN (DECL_CHAIN (TYPE_FIELDS (desc_type))); - /* The POINTER field is the 4th field in the descriptor. */ - tree pointer = DECL_CHAIN (klass); - - /* Retrieve the value of the POINTER field. */ - tree gnu_expr32 - = build3 (COMPONENT_REF, TREE_TYPE (pointer), desc, pointer, NULL_TREE); - - if (POINTER_TYPE_P (gnu_type)) - return convert (gnu_type, gnu_expr32); - - else if (TYPE_IS_FAT_POINTER_P (gnu_type)) - { - tree p_array_type = TREE_TYPE (TYPE_FIELDS (gnu_type)); - tree p_bounds_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))); - tree template_type = TREE_TYPE (p_bounds_type); - tree min_field = TYPE_FIELDS (template_type); - tree max_field = DECL_CHAIN (TYPE_FIELDS (template_type)); - tree template_tree, template_addr, aflags, dimct, t, u; - /* See the head comment of build_vms_descriptor. */ - int iklass = TREE_INT_CST_LOW (DECL_INITIAL (klass)); - vec *v; - - /* Convert POINTER to the pointer-to-array type. */ - gnu_expr32 = convert (p_array_type, gnu_expr32); - - switch (iklass) - { - case 1: /* Class S */ - case 15: /* Class SB */ - /* Build {1, LENGTH} template; LENGTH is the 1st field. */ - vec_alloc (v, 2); - t = TYPE_FIELDS (desc_type); - t = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - CONSTRUCTOR_APPEND_ELT (v, min_field, - convert (TREE_TYPE (min_field), - integer_one_node)); - CONSTRUCTOR_APPEND_ELT (v, max_field, - convert (TREE_TYPE (max_field), t)); - template_tree = gnat_build_constructor (template_type, v); - template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template_tree); - - /* For class S, we are done. */ - if (iklass == 1) - break; - - /* Test that we really have a SB descriptor, like DEC Ada. */ - t = build3 (COMPONENT_REF, TREE_TYPE (klass), desc, klass, NULL); - u = convert (TREE_TYPE (klass), DECL_INITIAL (klass)); - u = build_binary_op (EQ_EXPR, boolean_type_node, t, u); - /* If so, there is already a template in the descriptor and - it is located right after the POINTER field. */ - t = DECL_CHAIN (pointer); - template_tree - = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* Otherwise use the {1, LENGTH} template we build above. */ - template_addr = build3 (COND_EXPR, p_bounds_type, u, - build_unary_op (ADDR_EXPR, p_bounds_type, - template_tree), - template_addr); - break; - - case 4: /* Class A */ - /* The AFLAGS field is the 7th field in the descriptor. */ - t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (pointer))); - aflags = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* The DIMCT field is the 8th field in the descriptor. */ - t = DECL_CHAIN (t); - dimct = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - /* Raise CONSTRAINT_ERROR if either more than 1 dimension - or FL_COEFF or FL_BOUNDS not set. */ - u = build_int_cst (TREE_TYPE (aflags), 192); - u = build_binary_op (TRUTH_OR_EXPR, boolean_type_node, - build_binary_op (NE_EXPR, boolean_type_node, - dimct, - convert (TREE_TYPE (dimct), - size_one_node)), - build_binary_op (NE_EXPR, boolean_type_node, - build2 (BIT_AND_EXPR, - TREE_TYPE (aflags), - aflags, u), - u)); - /* There is already a template in the descriptor and it is - located at the start of block 3 (12th field). */ - t = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (t)))); - template_tree - = build3 (COMPONENT_REF, TREE_TYPE (t), desc, t, NULL_TREE); - template_tree = build3 (COND_EXPR, TREE_TYPE (t), u, - build_call_raise (CE_Length_Check_Failed, Empty, - N_Raise_Constraint_Error), - template_tree); - template_addr - = build_unary_op (ADDR_EXPR, p_bounds_type, template_tree); - break; - - case 10: /* Class NCA */ - default: - post_error ("unsupported descriptor type for &", gnat_subprog); - template_addr = integer_zero_node; - break; - } - - /* Build the fat pointer in the form of a constructor. */ - vec_alloc (v, 2); - CONSTRUCTOR_APPEND_ELT (v, TYPE_FIELDS (gnu_type), gnu_expr32); - CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (TYPE_FIELDS (gnu_type)), - template_addr); - - return gnat_build_constructor (gnu_type, v); - } - - else - gcc_unreachable (); -} - -/* Convert GNU_EXPR, a pointer to a VMS descriptor, to GNU_TYPE, a regular - pointer or fat pointer type. GNU_EXPR_ALT_TYPE is the alternate (32-bit) - pointer type of GNU_EXPR. GNAT_SUBPROG is the subprogram to which the - descriptor is passed. */ - -tree -convert_vms_descriptor (tree gnu_type, tree gnu_expr, tree gnu_expr_alt_type, - Entity_Id gnat_subprog) -{ - tree desc_type = TREE_TYPE (TREE_TYPE (gnu_expr)); - tree desc = build1 (INDIRECT_REF, desc_type, gnu_expr); - tree mbo = TYPE_FIELDS (desc_type); - const char *mbostr = IDENTIFIER_POINTER (DECL_NAME (mbo)); - tree mbmo = DECL_CHAIN (DECL_CHAIN (DECL_CHAIN (mbo))); - tree is64bit, gnu_expr32, gnu_expr64; - - /* If the field name is not MBO, it must be 32-bit and no alternate. - Otherwise primary must be 64-bit and alternate 32-bit. */ - if (strcmp (mbostr, "MBO") != 0) - { - tree ret = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); - return ret; - } - - /* Build the test for 64-bit descriptor. */ - mbo = build3 (COMPONENT_REF, TREE_TYPE (mbo), desc, mbo, NULL_TREE); - mbmo = build3 (COMPONENT_REF, TREE_TYPE (mbmo), desc, mbmo, NULL_TREE); - is64bit - = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node, - build_binary_op (EQ_EXPR, boolean_type_node, - convert (integer_type_node, mbo), - integer_one_node), - build_binary_op (EQ_EXPR, boolean_type_node, - convert (integer_type_node, mbmo), - integer_minus_one_node)); - - /* Build the 2 possible end results. */ - gnu_expr64 = convert_vms_descriptor64 (gnu_type, gnu_expr, gnat_subprog); - gnu_expr = fold_convert (gnu_expr_alt_type, gnu_expr); - gnu_expr32 = convert_vms_descriptor32 (gnu_type, gnu_expr, gnat_subprog); - return build3 (COND_EXPR, gnu_type, is64bit, gnu_expr64, gnu_expr32); -} - /* Build a type to be used to represent an aliased object whose nominal type is an unconstrained array. This consists of a RECORD_TYPE containing a field of TEMPLATE_TYPE and a field of OBJECT_TYPE, which is an ARRAY_TYPE. @@ -4254,6 +3658,7 @@ tree build_unc_object_type (tree template_type, tree object_type, tree name, bool debug_info_p) { + tree decl; tree type = make_node (RECORD_TYPE); tree template_field = create_field_decl (get_identifier ("BOUNDS"), template_type, type, @@ -4269,7 +3674,12 @@ build_unc_object_type (tree template_type, tree object_type, tree name, /* Declare it now since it will never be declared otherwise. This is necessary to ensure that its subtrees are properly marked. */ - create_type_decl (name, type, true, debug_info_p, Empty); + decl = create_type_decl (name, type, true, debug_info_p, Empty); + + /* template_type will not be used elsewhere than here, so to keep the debug + info clean and in order to avoid scoping issues, make decl its + context. */ + gnat_set_type_context (template_type, decl); return type; } @@ -4648,9 +4058,9 @@ convert (tree type, tree expr) /* If the input is a biased type, adjust first. */ 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), - expr), - TYPE_MIN_VALUE (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 @@ -4956,7 +4366,8 @@ convert (tree type, tree expr) return fold_convert (type, fold_build2 (MINUS_EXPR, TREE_TYPE (type), convert (TREE_TYPE (type), expr), - TYPE_MIN_VALUE (type))); + convert (TREE_TYPE (type), + TYPE_MIN_VALUE (type)))); /* ... fall through ... */ @@ -5370,12 +4781,10 @@ unchecked_convert (tree type, tree expr, bool notrunc_p) /* If both types types are integral just do a normal conversion. Likewise for a conversion to an unconstrained array. */ - if ((((INTEGRAL_TYPE_P (type) - && !(code == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (type))) + if (((INTEGRAL_TYPE_P (type) || (POINTER_TYPE_P (type) && !TYPE_IS_THIN_POINTER_P (type)) || (code == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (type))) - && ((INTEGRAL_TYPE_P (etype) - && !(ecode == INTEGER_TYPE && TYPE_VAX_FLOATING_POINT_P (etype))) + && (INTEGRAL_TYPE_P (etype) || (POINTER_TYPE_P (etype) && !TYPE_IS_THIN_POINTER_P (etype)) || (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))) || code == UNCONSTRAINED_ARRAY_TYPE) @@ -5757,7 +5166,8 @@ gnat_write_global_declarations (void) void_type_node); DECL_HARD_REGISTER (dummy_global) = 1; TREE_STATIC (dummy_global) = 1; - node = varpool_node_for_decl (dummy_global); + node = varpool_node::get_create (dummy_global); + node->definition = 1; node->definition = 1; node->force_output = 1; @@ -5773,7 +5183,7 @@ gnat_write_global_declarations (void) for example pointers to Taft amendment types, have their compilation finalized in the right context. */ FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) - if (TREE_CODE (iter) == TYPE_DECL) + if (TREE_CODE (iter) == TYPE_DECL && !DECL_IGNORED_P (iter)) debug_hooks->global_decl (iter); /* Proceed to optimize and emit assembly. */ @@ -5785,7 +5195,7 @@ gnat_write_global_declarations (void) { timevar_push (TV_SYMOUT); FOR_EACH_VEC_SAFE_ELT (global_decls, i, iter) - if (TREE_CODE (iter) != TYPE_DECL) + if (TREE_CODE (iter) != TYPE_DECL && !DECL_IGNORED_P (iter)) debug_hooks->global_decl (iter); timevar_pop (TV_SYMOUT); } @@ -6351,8 +5761,7 @@ handle_noreturn_attribute (tree *node, tree name, tree ARG_UNUSED (args), struct attribute_spec.handler. */ static tree -handle_leaf_attribute (tree *node, tree name, - tree ARG_UNUSED (args), +handle_leaf_attribute (tree *node, tree name, tree ARG_UNUSED (args), int ARG_UNUSED (flags), bool *no_add_attrs) { if (TREE_CODE (*node) != FUNCTION_DECL) @@ -6369,6 +5778,27 @@ handle_leaf_attribute (tree *node, tree name, return NULL_TREE; } +/* Handle a "always_inline" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_always_inline_attribute (tree *node, tree name, tree ARG_UNUSED (args), + int ARG_UNUSED (flags), bool *no_add_attrs) +{ + if (TREE_CODE (*node) == FUNCTION_DECL) + { + /* Set the attribute and mark it for disregarding inline limits. */ + DECL_DISREGARD_INLINE_LIMITS (*node) = 1; + } + else + { + warning (OPT_Wattributes, "%qE attribute ignored", name); + *no_add_attrs = true; + } + + return NULL_TREE; +} + /* Handle a "malloc" attribute; arguments as in struct attribute_spec.handler. */ diff --git a/main/gcc/ada/gcc-interface/utils2.c b/main/gcc/ada/gcc-interface/utils2.c index dd4151b5bc5..8297c068dbc 100644 --- a/main/gcc/ada/gcc-interface/utils2.c +++ b/main/gcc/ada/gcc-interface/utils2.c @@ -300,10 +300,14 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2) last < first holds. */ if (integer_zerop (length2)) { + tree b = get_base_type (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + length_zero_p = true; - ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + ub1 + = convert (b, TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)))); + lb1 + = convert (b, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)))); comparison = fold_build2_loc (loc, LT_EXPR, result_type, ub1, lb1); comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); @@ -319,20 +323,23 @@ compare_arrays (location_t loc, tree result_type, tree a1, tree a2) just use its length computed from the actual stored bounds. */ else if (TREE_CODE (length2) == INTEGER_CST) { - tree bt; + tree b = get_base_type (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); - lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1))); + ub1 + = convert (b, TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)))); + lb1 + = convert (b, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)))); /* Note that we know that UB2 and LB2 are constant and hence cannot contain a PLACEHOLDER_EXPR. */ - ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); - lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2))); - bt = get_base_type (TREE_TYPE (ub1)); + ub2 + = convert (b, TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)))); + lb2 + = convert (b, TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)))); comparison = fold_build2_loc (loc, EQ_EXPR, result_type, - build_binary_op (MINUS_EXPR, bt, ub1, lb1), - build_binary_op (MINUS_EXPR, bt, ub2, lb2)); + build_binary_op (MINUS_EXPR, b, ub1, lb1), + build_binary_op (MINUS_EXPR, b, ub2, lb2)); comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1); if (EXPR_P (comparison)) SET_EXPR_LOCATION (comparison, loc); @@ -1177,7 +1184,6 @@ build_binary_op (enum tree_code op_code, tree result_type, ; else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF) { - TREE_THIS_NOTRAP (result) = 1; if (TYPE_VOLATILE (operation_type)) TREE_THIS_VOLATILE (result) = 1; } @@ -1996,7 +2002,8 @@ build_simple_component_ref (tree record_variable, tree component, tree field, /* Look through a conversion between original and packable version, but the field needs to be adjusted in this case. */ - else if (TYPE_NAME (inner_type) == TYPE_NAME (record_type)) + else if (RECORD_OR_UNION_TYPE_P (inner_type) + && TYPE_NAME (inner_type) == TYPE_NAME (record_type)) { tree new_field; @@ -2153,18 +2160,7 @@ maybe_wrap_malloc (tree data_size, tree data_type, Node_Id gnat_node) tree size_to_malloc = aligning_type ? TYPE_SIZE_UNIT (aligning_type) : data_size; - tree malloc_ptr; - - /* On VMS, if pointers are 64-bit and the allocator size is 32-bit or - Convention C, allocate 32-bit memory. */ - if (TARGET_ABI_OPEN_VMS - && POINTER_SIZE == 64 - && Nkind (gnat_node) == N_Allocator - && (UI_To_Int (Esize (Etype (gnat_node))) == 32 - || Convention (Etype (gnat_node)) == Convention_C)) - malloc_ptr = build_call_n_expr (malloc32_decl, 1, size_to_malloc); - else - malloc_ptr = build_call_n_expr (malloc_decl, 1, size_to_malloc); + tree malloc_ptr = build_call_n_expr (malloc_decl, 1, size_to_malloc); if (aligning_type) { diff --git a/main/gcc/ada/get_targ.adb b/main/gcc/ada/get_targ.adb index 661f95b5ab3..9dde22bebf6 100644 --- a/main/gcc/ada/get_targ.adb +++ b/main/gcc/ada/get_targ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -293,25 +293,29 @@ package body Get_Targ is return C_Get_Double_Scalar_Alignment; end Get_Double_Scalar_Alignment; + ------------------------------ + -- Get_Back_End_Config_File -- + ------------------------------ + + function Get_Back_End_Config_File return String_Ptr is + begin + return null; + end Get_Back_End_Config_File; + ---------------------- -- Digits_From_Size -- ---------------------- function Digits_From_Size (Size : Pos) return Pos is begin - if Size = 32 then - return 6; - elsif Size = 48 then - return 9; - elsif Size = 64 then - return 15; - elsif Size = 96 then - return 18; - elsif Size = 128 then - return 18; - else - raise Program_Error; - end if; + case Size is + when 32 => return 6; + when 48 => return 9; + when 64 => return 15; + when 96 => return 18; + when 128 => return 18; + when others => raise Program_Error; + end case; end Digits_From_Size; ----------------------------- @@ -340,17 +344,13 @@ package body Get_Targ is function Width_From_Size (Size : Pos) return Pos is begin - if Size = 8 then - return 4; - elsif Size = 16 then - return 6; - elsif Size = 32 then - return 11; - elsif Size = 64 then - return 21; - else - raise Program_Error; - end if; + case Size is + when 8 => return 4; + when 16 => return 6; + when 32 => return 11; + when 64 => return 21; + when others => raise Program_Error; + end case; end Width_From_Size; end Get_Targ; diff --git a/main/gcc/ada/get_targ.ads b/main/gcc/ada/get_targ.ads index 98be7c9a771..457575eddd9 100644 --- a/main/gcc/ada/get_targ.ads +++ b/main/gcc/ada/get_targ.ads @@ -145,4 +145,9 @@ package Get_Targ is procedure Register_Back_End_Types (Call_Back : Register_Type_Proc); -- Calls the Call_Back function with information for each supported type + function Get_Back_End_Config_File return String_Ptr; + -- Return the back end configuration file, or null if none. If non-null, + -- this file should be used instead of calling the various Get_xxx + -- functions in this package. + end Get_Targ; diff --git a/main/gcc/ada/gnat.ads b/main/gcc/ada/gnat.ads index cfdfdc837eb..a0807b656fa 100644 --- a/main/gcc/ada/gnat.ads +++ b/main/gcc/ada/gnat.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 AdaCore -- +-- Copyright (C) 1992-2014, 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- -- diff --git a/main/gcc/ada/gnat1drv.adb b/main/gcc/ada/gnat1drv.adb index 756961e3d2d..50f4befcc10 100644 --- a/main/gcc/ada/gnat1drv.adb +++ b/main/gcc/ada/gnat1drv.adb @@ -32,13 +32,11 @@ with Debug; use Debug; with Elists; with Errout; use Errout; with Exp_CG; -with Exp_Ch6; use Exp_Ch6; with Fmap; with Fname; use Fname; with Fname.UF; use Fname.UF; with Frontend; with Gnatvsn; use Gnatvsn; -with Hostparm; with Inline; with Lib; use Lib; with Lib.Writ; use Lib.Writ; @@ -82,6 +80,7 @@ with Usage; with Validsw; use Validsw; with System.Assertions; +with System.OS_Lib; -------------- -- Gnat1drv -- @@ -334,6 +333,12 @@ procedure Gnat1drv is Front_End_Inlining := False; Inline_Active := False; + -- Issue warnings for failure to inline subprograms, as otherwise + -- expected in GNATprove mode for the local subprograms without + -- contracts. + + Ineffective_Inline_Warnings := True; + -- Disable front-end optimizations, to keep the tree as close to the -- source code as possible, and also to avoid inconsistencies between -- trees when using different optimization switches. @@ -366,9 +371,11 @@ procedure Gnat1drv is -- Detect overflow on unconstrained floating-point types, such as -- the predefined types Float, Long_Float and Long_Long_Float from - -- package Standard. + -- package Standard. Not necessary if float overflows are checked + -- (Machine_Overflow true), since appropriate Do_Overflow_Check flags + -- will be set in any case. - Check_Float_Overflow := True; + Check_Float_Overflow := not Machine_Overflows_On_Target; -- Set STRICT mode for overflow checks if not set explicitly. This -- prevents suppressing of overflow checks by default, in code down @@ -470,17 +477,6 @@ procedure Gnat1drv is Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian; end if; - -- Deal with forcing OpenVMS switches True if debug flag M is set, but - -- record the setting of Targparm.Open_VMS_On_Target in True_VMS_Target - -- before doing this, so we know if we are in real OpenVMS or not. - - Opt.True_VMS_Target := Targparm.OpenVMS_On_Target; - - if Debug_Flag_M then - Targparm.OpenVMS_On_Target := True; - Hostparm.OpenVMS := True; - end if; - -- Activate front end layout if debug flag -gnatdF is set if Debug_Flag_FF then @@ -504,9 +500,13 @@ procedure Gnat1drv is -- Otherwise set overflow mode defaults else - -- Otherwise set overflow checks off by default + -- Overflow checks are on by default (Suppress set False) except in + -- GNAT_Mode, where we want them off by default (we are not ready to + -- enable overflow checks in the compiler yet, for one thing the case + -- of 64-bit checks needs System.Arith_64 which is not a compiler + -- unit and it is a pain to try to include it in the compiler. - Suppress_Options.Suppress (Overflow_Check) := True; + Suppress_Options.Suppress (Overflow_Check) := GNAT_Mode; -- Set appropriate default overflow handling mode. Note: at present -- we set STRICT in all three of the following cases. They are @@ -524,8 +524,8 @@ procedure Gnat1drv is -- flags set, so this was dead code anyway. elsif Targparm.Backend_Divide_Checks_On_Target - and - Targparm.Backend_Overflow_Checks_On_Target + and + Targparm.Backend_Overflow_Checks_On_Target then Suppress_Options.Overflow_Mode_General := Strict; Suppress_Options.Overflow_Mode_Assertions := Strict; @@ -583,6 +583,38 @@ procedure Gnat1drv is end if; end if; + -- Set back end inlining indication + + Back_End_Inlining := + + -- No back end inlining if inlining is suppressed + + not Suppress_All_Inlining + + -- No back end inlining available for VM targets + + and then VM_Target = No_VM + + -- No back end inlining available on AAMP + + and then not AAMP_On_Target + + -- 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. + -- 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 + + and then not Debug_Flag_Dot_Z; + -- Output warning if -gnateE specified and cannot be supported if Exception_Extra_Info @@ -832,53 +864,68 @@ begin Sem_Eval.Initialize; Sem_Type.Init_Interp_Tables; - -- Acquire target parameters from system.ads (source of package System) + -- Capture compilation date and time - Targparm_Acquire : declare - use Sinput; + Opt.Compilation_Time := System.OS_Lib.Current_Time_String; - S : Source_File_Index; - N : File_Name_Type; + -- Get the target parameters only when -gnats is not used, to avoid + -- failing when there is no default runtime. - begin - Name_Buffer (1 .. 10) := "system.ads"; - Name_Len := 10; - N := Name_Find; - S := Load_Source_File (N); + if Operating_Mode /= Check_Syntax then - if S = No_Source_File then - Write_Line - ("fatal error, run-time library not installed correctly"); - Write_Line ("cannot locate file system.ads"); - raise Unrecoverable_Error; + -- Acquire target parameters from system.ads (package System source) - -- Remember source index of system.ads (which was read successfully) + Targparm_Acquire : declare + use Sinput; - else - System_Source_File_Index := S; - end if; + S : Source_File_Index; + N : File_Name_Type; + + begin + Name_Buffer (1 .. 10) := "system.ads"; + Name_Len := 10; + N := Name_Find; + S := Load_Source_File (N); + + -- Failed to read system.ads, fatal error + + if S = No_Source_File then + Write_Line + ("fatal error, run-time library not installed correctly"); + Write_Line ("cannot locate file system.ads"); + raise Unrecoverable_Error; - Targparm.Get_Target_Parameters - (System_Text => Source_Text (S), - Source_First => Source_First (S), - Source_Last => Source_Last (S), - Make_Id => Tbuild.Make_Id'Access, - Make_SC => Tbuild.Make_SC'Access, - Set_RND => Tbuild.Set_RND'Access); + -- Read system.ads successfully, remember its source index - -- Acquire configuration pragma information from Targparm + else + System_Source_File_Index := S; + end if; + + Targparm.Get_Target_Parameters + (System_Text => Source_Text (S), + Source_First => Source_First (S), + Source_Last => Source_Last (S), + Make_Id => Tbuild.Make_Id'Access, + Make_SC => Tbuild.Make_SC'Access, + Set_RND => Tbuild.Set_RND'Access); - Restrict.Restrictions := Targparm.Restrictions_On_Target; - end Targparm_Acquire; + -- Acquire configuration pragma information from Targparm + + Restrict.Restrictions := Targparm.Restrictions_On_Target; + end Targparm_Acquire; + end if; -- Perform various adjustments and settings of global switches Adjust_Global_Switches; -- Output copyright notice if full list mode unless we have a list - -- file, in which case we defer this so that it is output in the file + -- file, in which case we defer this so that it is output in the file. if (Verbose_Mode or else (Full_List and then Full_List_File_Name = null)) + + -- Debug flag gnatd7 suppresses this copyright notice + and then not Debug_Flag_7 then Write_Eol; @@ -1198,6 +1245,19 @@ begin Prepcomp.Add_Dependencies; + -- In gnatprove mode we're writing the ALI much earlier than usual + -- as flow analysis needs the file present in order to append its + -- own globals to it. + + if GNATprove_Mode then + + -- Note: In GNATprove mode, an "object" file is always generated as + -- the result of calling gnat1 or gnat2why, although this is not the + -- same as the object file produced for compilation. + + Write_ALI (Object => True); + end if; + -- Back end needs to explicitly unlock tables it needs to touch Atree.Lock; @@ -1239,7 +1299,7 @@ begin Errout.Finalize (Last_Call => True); Errout.Output_Messages; List_Rep_Info (Ttypes.Bytes_Big_Endian); - List_Inlining_Info; + Inline.List_Inlining_Info; -- Only write the library if the backend did not generate any error -- messages. Otherwise signal errors to the driver program so that @@ -1250,12 +1310,9 @@ begin Exit_Program (E_Errors); end if; - -- In GNATprove mode, an "object" file is always generated as the - -- result of calling gnat1 or gnat2why, although this is not the - -- same as the object file produced for compilation. - - Write_ALI (Object => (Back_End_Mode = Generate_Object - or else GNATprove_Mode)); + if not GNATprove_Mode then + Write_ALI (Object => (Back_End_Mode = Generate_Object)); + end if; if not Compilation_Errors then diff --git a/main/gcc/ada/gnat_rm.texi b/main/gcc/ada/gnat_rm.texi index b1bcfb75c7d..e5a52bc23f1 100644 --- a/main/gcc/ada/gnat_rm.texi +++ b/main/gcc/ada/gnat_rm.texi @@ -1,4 +1,3 @@ - \input texinfo @c -*-texinfo-*- @c %**start of header @@ -112,7 +111,7 @@ Implementation Defined Pragmas * Pragma Assertion_Policy:: * Pragma Assume:: * Pragma Assume_No_Invalid_Values:: -* Pragma Ast_Entry:: +* Pragma AST_Entry:: * Pragma Async_Readers:: * Pragma Async_Writers:: * Pragma Attribute_Definition:: @@ -140,6 +139,7 @@ Implementation Defined Pragmas * Pragma CPU:: * Pragma Debug:: * Pragma Debug_Policy:: +* Pragma Default_Scalar_Storage_Order:: * Pragma Default_Storage_Pool:: * Pragma Depends:: * Pragma Detect_Blocking:: @@ -195,6 +195,7 @@ Implementation Defined Pragmas * Pragma Linker_Constructor:: * Pragma Linker_Destructor:: * Pragma Linker_Section:: +* Pragma Lock_Free:: * Pragma Long_Float:: * Pragma Loop_Invariant:: * Pragma Loop_Optimize:: @@ -203,6 +204,7 @@ Implementation Defined Pragmas * Pragma Main:: * Pragma Main_Storage:: * Pragma No_Body:: +* Pragma No_Elaboration_Code_All:: * Pragma No_Inline:: * Pragma No_Return:: * Pragma No_Run_Time:: @@ -233,6 +235,7 @@ Implementation Defined Pragmas * Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: * Pragma Pure_Function:: +* Pragma Rational:: * Pragma Ravenscar:: * Pragma Refined_Depends:: * Pragma Refined_Global:: @@ -270,6 +273,7 @@ Implementation Defined Pragmas * Pragma Type_Invariant:: * Pragma Type_Invariant_Class:: * Pragma Unchecked_Union:: +* Pragma Unevaluated_Use_Of_Old:: * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: * Pragma Universal_Data:: @@ -304,8 +308,12 @@ Implementation Defined Aspects * Aspect Initializes:: * Aspect Inline_Always:: * Aspect Invariant:: +* Aspect Invariant'Class:: +* Aspect Iterable:: * Aspect Linker_Section:: +* Aspect No_Elaboration_Code_All:: * Aspect Object_Size:: +* Aspect Obsolescent:: * Aspect Part_Of:: * Aspect Persistent_BSS:: * Aspect Predicate:: @@ -338,11 +346,14 @@ Implementation Defined Attributes * Attribute Asm_Input:: * Attribute Asm_Output:: * Attribute AST_Entry:: +* Attribute Atomic_Always_Lock_Free:: * Attribute Bit:: * Attribute Bit_Position:: -* Attribute Compiler_Version:: * Attribute Code_Address:: +* Attribute Compiler_Version:: +* Attribute Constrained:: * Attribute Default_Bit_Order:: +* Attribute Default_Scalar_Storage_Order:: * Attribute Descriptor_Size:: * Attribute Elaborated:: * Attribute Elab_Body:: @@ -353,14 +364,18 @@ Implementation Defined Attributes * Attribute Enum_Rep:: * Attribute Enum_Val:: * Attribute Epsilon:: +* Attribute Fast_Math:: * Attribute Fixed_Value:: +* Attribute From_Any:: * Attribute Has_Access_Values:: * Attribute Has_Discriminants:: * Attribute Img:: * Attribute Integer_Value:: * Attribute Invalid_Value:: +* Attribute Iterable:: * Attribute Large:: * Attribute Library_Level:: +* Attribute Lock_Free:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -368,6 +383,7 @@ Implementation Defined Attributes * Attribute Mechanism_Code:: * Attribute Null_Parameter:: * Attribute Object_Size:: +* Attribute Old:: * Attribute Passed_By_Reference:: * Attribute Pool_Address:: * Attribute Range_Length:: @@ -376,6 +392,7 @@ Implementation Defined Attributes * Attribute Result:: * Attribute Safe_Emax:: * Attribute Safe_Large:: +* Attribute Safe_Small:: * Attribute Scalar_Storage_Order:: * Attribute Simple_Storage_Pool:: * Attribute Small:: @@ -383,16 +400,18 @@ Implementation Defined Attributes * Attribute Stub_Type:: * Attribute System_Allocator_Alignment:: * Attribute Target_Name:: -* Attribute Tick:: * Attribute To_Address:: +* Attribute To_Any:: * Attribute Type_Class:: +* Attribute Type_Key:: +* Attribute TypeCode:: * Attribute UET_Address:: * Attribute Unconstrained_Array:: * Attribute Universal_Literal_String:: * Attribute Unrestricted_Access:: * Attribute Update:: -* Attribute Valid_Scalars:: * Attribute VADS_Size:: +* Attribute Valid_Scalars:: * Attribute Value_Size:: * Attribute Wchar_T_Size:: * Attribute Word_Size:: @@ -580,6 +599,7 @@ The GNAT Library * GNAT.Expect (g-expect.ads):: * GNAT.Expect.TTY (g-exptty.ads):: * GNAT.Float_Control (g-flocon.ads):: +* GNAT.Formatted_String (g-forstr.ads):: * GNAT.Heap_Sort (g-heasor.ads):: * GNAT.Heap_Sort_A (g-hesora.ads):: * GNAT.Heap_Sort_G (g-hesorg.ads):: @@ -635,7 +655,6 @@ The GNAT Library * GNAT.Wide_Wide_String_Split (g-zistsp.ads):: * Interfaces.C.Extensions (i-cexten.ads):: * Interfaces.C.Streams (i-cstrea.ads):: -* Interfaces.CPP (i-cpp.ads):: * Interfaces.Packed_Decimal (i-pacdec.ads):: * Interfaces.VxWorks (i-vxwork.ads):: * Interfaces.VxWorks.IO (i-vxwoio.ads):: @@ -961,7 +980,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Assertion_Policy:: * Pragma Assume:: * Pragma Assume_No_Invalid_Values:: -* Pragma Ast_Entry:: +* Pragma AST_Entry:: * Pragma Async_Readers:: * Pragma Async_Writers:: * Pragma Attribute_Definition:: @@ -989,6 +1008,7 @@ consideration, the use of these pragmas should be minimized. * Pragma CPU:: * Pragma Debug:: * Pragma Debug_Policy:: +* Pragma Default_Scalar_Storage_Order:: * Pragma Default_Storage_Pool:: * Pragma Depends:: * Pragma Detect_Blocking:: @@ -1044,6 +1064,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Linker_Constructor:: * Pragma Linker_Destructor:: * Pragma Linker_Section:: +* Pragma Lock_Free:: * Pragma Long_Float:: * Pragma Loop_Invariant:: * Pragma Loop_Optimize:: @@ -1052,6 +1073,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Main:: * Pragma Main_Storage:: * Pragma No_Body:: +* Pragma No_Elaboration_Code_All:: * Pragma No_Inline:: * Pragma No_Return:: * Pragma No_Run_Time:: @@ -1082,6 +1104,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Provide_Shift_Operators:: * Pragma Psect_Object:: * Pragma Pure_Function:: +* Pragma Rational:: * Pragma Ravenscar:: * Pragma Refined_Depends:: * Pragma Refined_Global:: @@ -1119,6 +1142,7 @@ consideration, the use of these pragmas should be minimized. * Pragma Type_Invariant:: * Pragma Type_Invariant_Class:: * Pragma Unchecked_Union:: +* Pragma Unevaluated_Use_Of_Old:: * Pragma Unimplemented_Unit:: * Pragma Universal_Aliasing :: * Pragma Universal_Data:: @@ -1548,12 +1572,12 @@ useful when the pragma or aspect argument references subprograms in a with'ed package which is replaced by a dummy package for the final build. -The implementation defined policy @code{Assertions} applies to all +The implementation defined assertion kind @code{Assertions} applies to all assertion kinds. The form with no assertion kind given implies this choice, so it applies to all assertion kinds (RM defined, and implementation defined). -The implementation defined policy @code{Statement_Assertions} +The implementation defined assertion kind @code{Statement_Assertions} applies to @code{Assert}, @code{Assert_And_Cut}, @code{Assume}, @code{Loop_Invariant}, and @code{Loop_Variant}. @@ -1656,10 +1680,10 @@ section 7.1.2. For the description of this pragma, see SPARK 2014 Reference Manual, section 7.1.2. -@node Pragma Ast_Entry -@unnumberedsec Pragma Ast_Entry +@node Pragma AST_Entry +@unnumberedsec Pragma AST_Entry @cindex OpenVMS -@findex Ast_Entry +@findex AST_Entry @noindent Syntax: @smallexample @c ada @@ -2505,8 +2529,79 @@ This pragma is equivalent to a corresponding @code{Check_Policy} pragma with a first argument of @code{Debug}. It is retained for historical compatibility reasons. +@node Pragma Default_Scalar_Storage_Order +@unnumberedsec Pragma Default_Scalar_Storage_Order +@cindex Default_Scalar_Storage_Order +@cindex Scalar_Storage_Order +@findex Default_Scalar_Storage_Order +@noindent +Syntax: + +@smallexample @c ada +pragma Default_Scalar_Storage_Order (High_Order_First | Low_Order_First); +@end smallexample + +@noindent +Normally if no explicit @code{Scalar_Storage_Order} is given for a record +type or array type, then the scalar storage order defaults to the ordinary +default for the target. But this default may be overridden using this pragma. +The pragma may appear as a configuration pragma, or locally within a package +spec or declarative part. In the latter case, it applies to all subsequent +types declared within that package spec or declarative part. + +If this pragma is used as a configuration pragma which appears within a +configuration pragma file (as opposed to appearing explicitly at the start +of a single unit), then the binder will require that all units in a partition +be compiled in a similar manner, including all units in the run-time that +are included in the partition. + +The following example shows the use of this pragma: + +@smallexample @c ada +pragma Default_Scalar_Storage_Order (High_Order_First); +with System; use System; +package DSSO1 is + type H1 is record + a : Integer; + end record; + + type L2 is record + a : Integer; + end record; + for L2'Scalar_Storage_Order use Low_Order_First; + + type L2a is new L2; + + package Inner is + type H3 is record + a : Integer; + end record; + + pragma Default_Scalar_Storage_Order (Low_Order_First); + + type L4 is record + a : Integer; + end record; + end Inner; + + type H4a is new Inner.L4; + + type H5 is record + a : Integer; + end record; +end DSSO1; +@end smallexample + +@noindent +In this example record types L.. have @code{Low_Order_First} scalar +storage order, and record types H.. have @code{High_Order_First}. +Note that in the case of @code{H4a}, the order is not inherited +from the parent type. Only an explicitly set @code{Scalar_Storage_Order} +gets inherited on type derivation. + @node Pragma Default_Storage_Pool @unnumberedsec Pragma Default_Storage_Pool +@cindex Default_Storage_Pool @findex Default_Storage_Pool @noindent Syntax: @@ -2793,13 +2888,7 @@ MECHANISM ::= MECHANISM_ASSOCIATION ::= [formal_parameter_NAME =>] MECHANISM_NAME -MECHANISM_NAME ::= - Value -| Reference -| Descriptor [([Class =>] CLASS_NAME)] -| Short_Descriptor [([Class =>] CLASS_NAME)] - -CLASS_NAME ::= ubs | ubsb | uba | s | sb | a +MECHANISM_NAME ::= Value | Reference @end smallexample @noindent @@ -2827,13 +2916,6 @@ using positional notation to match parameters with subtype marks. The form with an @code{'Access} attribute can be used to match an anonymous access parameter. -@cindex OpenVMS -@cindex Passing by descriptor -Passing by descriptor is supported only on the OpenVMS ports of GNAT@. -The default behavior for Export_Function is to accept either 64bit or -32bit descriptors unless short_descriptor is specified, then only 32bit -descriptors are accepted. - @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null string or a static string expressions that evaluates to the null @@ -2898,13 +2980,7 @@ MECHANISM ::= MECHANISM_ASSOCIATION ::= [formal_parameter_NAME =>] MECHANISM_NAME -MECHANISM_NAME ::= - Value -| Reference -| Descriptor [([Class =>] CLASS_NAME)] -| Short_Descriptor [([Class =>] CLASS_NAME)] - -CLASS_NAME ::= ubs | ubsb | uba | s | sb | a +MECHANISM_NAME ::= Value | Reference @end smallexample @noindent @@ -2917,13 +2993,6 @@ not what is wanted, so it is usually appropriate to use this pragma in conjunction with a @code{Export} or @code{Convention} pragma that specifies the desired foreign convention. -@cindex OpenVMS -@cindex Passing by descriptor -Passing by descriptor is supported only on the OpenVMS ports of GNAT@. -The default behavior for Export_Procedure is to accept either 64bit or -32bit descriptors unless short_descriptor is specified, then only 32bit -descriptors are accepted. - @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null string or a static string expressions that evaluates to the null @@ -2984,13 +3053,7 @@ MECHANISM ::= MECHANISM_ASSOCIATION ::= [formal_parameter_NAME =>] MECHANISM_NAME -MECHANISM_NAME ::= - Value -| Reference -| Descriptor [([Class =>] CLASS_NAME)] -| Short_Descriptor [([Class =>] CLASS_NAME)] - -CLASS_NAME ::= ubs | ubsb | uba | s | sb | a +MECHANISM_NAME ::= Value | Reference @end smallexample @noindent @@ -3008,13 +3071,6 @@ with foreign language functions, so it is usually appropriate to use this pragma in conjunction with a @code{Export} or @code{Convention} pragma that specifies the desired foreign convention. -@cindex OpenVMS -@cindex Passing by descriptor -Passing by descriptor is supported only on the OpenVMS ports of GNAT@. -The default behavior for Export_Valued_Procedure is to accept either 64bit or -32bit descriptors unless short_descriptor is specified, then only 32bit -descriptors are accepted. - @cindex Suppressing external name Special treatment is given if the EXTERNAL is an explicit null string or a static string expressions that evaluates to the null @@ -3336,17 +3392,8 @@ pragma Ident (static_string_EXPRESSION); @end smallexample @noindent -This pragma provides a string identification in the generated object file, -if the system supports the concept of this kind of identification string. -This pragma is allowed only in the outermost declarative part or -declarative items of a compilation unit. If more than one @code{Ident} -pragma is given, only the last one processed is effective. -@cindex OpenVMS -On OpenVMS systems, the effect of the pragma is identical to the effect of -the DEC Ada 83 pragma of the same name. Note that in DEC Ada 83, the -maximum allowed length is 31 characters, so if it is important to -maintain compatibility with this compiler, you should obey this length -limit. +This pragma is identical in effect to pragma @code{Comment}. It is provided +for compatibility with other Ada compilers providing this pragma. @node Pragma Implementation_Defined @unnumberedsec Pragma Implementation_Defined @@ -3518,8 +3565,7 @@ pragma Import_Function ( [, [Parameter_Types =>] PARAMETER_TYPES] [, [Result_Type =>] SUBTYPE_MARK] [, [Mechanism =>] MECHANISM] - [, [Result_Mechanism =>] MECHANISM_NAME] - [, [First_Optional_Parameter =>] IDENTIFIER]); + [, [Result_Mechanism =>] MECHANISM_NAME]); EXTERNAL_SYMBOL ::= IDENTIFIER @@ -3543,10 +3589,6 @@ MECHANISM_ASSOCIATION ::= MECHANISM_NAME ::= Value | Reference -| Descriptor [([Class =>] CLASS_NAME)] -| Short_Descriptor [([Class =>] CLASS_NAME)] - -CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca @end smallexample @noindent @@ -3575,21 +3617,6 @@ parameter by parameter basis using either positional or named notation. If the mechanism is not specified, the default mechanism is used. -@cindex OpenVMS -@cindex Passing by descriptor -Passing by descriptor is supported only on the OpenVMS ports of GNAT@. -The default behavior for Import_Function is to pass a 64bit descriptor -unless short_descriptor is specified, then a 32bit descriptor is passed. - -@code{First_Optional_Parameter} applies only to OpenVMS ports of GNAT@. -It specifies that the designated parameter and all following parameters -are optional, meaning that they are not passed at the generated code -level (this is distinct from the notion of optional parameters in Ada -where the parameters are passed anyway with the designated optional -parameters). All optional parameters must be of mode @code{IN} and have -default parameter values that are either known at compile time -expressions, or uses of the @code{'Null_Parameter} attribute. - @node Pragma Import_Object @unnumberedsec Pragma Import_Object @findex Import_Object @@ -3627,8 +3654,7 @@ pragma Import_Procedure ( [Internal =>] LOCAL_NAME [, [External =>] EXTERNAL_SYMBOL] [, [Parameter_Types =>] PARAMETER_TYPES] - [, [Mechanism =>] MECHANISM] - [, [First_Optional_Parameter =>] IDENTIFIER]); + [, [Mechanism =>] MECHANISM]); EXTERNAL_SYMBOL ::= IDENTIFIER @@ -3649,13 +3675,7 @@ MECHANISM ::= MECHANISM_ASSOCIATION ::= [formal_parameter_NAME =>] MECHANISM_NAME -MECHANISM_NAME ::= - Value -| Reference -| Descriptor [([Class =>] CLASS_NAME)] -| Short_Descriptor [([Class =>] CLASS_NAME)] - -CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca +MECHANISM_NAME ::= Value | Reference @end smallexample @noindent @@ -3674,8 +3694,7 @@ pragma Import_Valued_Procedure ( [Internal =>] LOCAL_NAME [, [External =>] EXTERNAL_SYMBOL] [, [Parameter_Types =>] PARAMETER_TYPES] - [, [Mechanism =>] MECHANISM] - [, [First_Optional_Parameter =>] IDENTIFIER]); + [, [Mechanism =>] MECHANISM]); EXTERNAL_SYMBOL ::= IDENTIFIER @@ -3696,13 +3715,7 @@ MECHANISM ::= MECHANISM_ASSOCIATION ::= [formal_parameter_NAME =>] MECHANISM_NAME -MECHANISM_NAME ::= - Value -| Reference -| Descriptor [([Class =>] CLASS_NAME)] -| Short_Descriptor [([Class =>] CLASS_NAME)] - -CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca +MECHANISM_NAME ::= Value | Reference @end smallexample @noindent @@ -4400,6 +4413,16 @@ package IO_Card is end IO_Card; @end smallexample +@node Pragma Lock_Free +@unnumberedsec Pragma Lock_Free +@findex Lock_Free +@noindent +Syntax: +This pragma may be specified for protected types or objects. It specifies that +the implementation of protected operations must be implemented without locks. +Compilation fails if the compiler cannot generate lock-free code for the +operations. + @node Pragma Long_Float @unnumberedsec Pragma Long_Float @cindex OpenVMS @@ -4478,7 +4501,9 @@ There are five supported optimization hints for a loop: @itemize @bullet @item Ivdep -The programmer asserts that there are no loop-carried dependencies which would prevent consecutive iterations of the loop from being executed simultaneously. +The programmer asserts that there are no loop-carried dependencies +which would prevent consecutive iterations of the loop from being +executed simultaneously. @item No_Unroll @@ -4504,7 +4529,7 @@ unrolling, but there is no guarantee that the loop will be vectorized. @end itemize -These hints do not void the need to pass the appropriate switches to the +These hints do not remove the need to pass the appropriate switches to the compiler in order to enable the relevant optimizations, that is to say @option{-funroll-loops} for unrolling and @option{-ftree-vectorize} for vectorization. @@ -4648,6 +4673,24 @@ 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. +@node Pragma No_Elaboration_Code_All +@unnumberedsec Pragma No_Elaboration_Code_All +@findex No_Elaboration_Code_All +@noindent +Syntax: + +@smallexample @c ada +pragma No_Elaboration_Code_All [(program_unit_NAME)]; +@end smallexample + +@noindent +This is a program unit pragma (there is also an equivalent aspect of the +same name) that establishes the restriction @code{No_Elaboration_Code} for +the current unit and any extended main source units (body and subunits. +It also has has the effect of enforcing a transitive application of this +aspect, so that if any unit is implicitly or explicitly WITH'ed by the +current unit, it must also have the No_Elaboration_Code_All aspect set. + @node Pragma No_Inline @unnumberedsec Pragma No_Inline @findex No_Inline @@ -5229,7 +5272,7 @@ and whose type is potentially persistent. If no argument is given, then the pragma is a configuration pragma, and applies to all library level objects with no explicit initialization of potentially persistent types. -A potentially persistent type is a scalar type, or a non-tagged, +A potentially persistent type is a scalar type, or an untagged, non-discriminated record, all of whose components have no explicit initialization and are themselves of a potentially persistent type, or an array, all of whose constraints are static, and whose component @@ -6001,6 +6044,24 @@ function is also considered pure from an optimization point of view, but the unit is not a Pure unit in the categorization sense. So for example, a function thus marked is free to @code{with} non-pure units. +@node Pragma Rational +@unnumberedsec Pragma Rational +@findex Rational +@noindent +Syntax: + +@smallexample @c ada +pragma Rational; +@end smallexample + +@noindent +This pragma is considered obsolescent, but is retained for +compatibility purposes. It is equivalent to: + +@smallexample @c ada +pragma Profile (Rational); +@end smallexample + @node Pragma Ravenscar @unnumberedsec Pragma Ravenscar @findex Pragma Ravenscar @@ -6316,11 +6377,8 @@ pragma Short_Descriptors @end smallexample @noindent -In VMS versions of the compiler, this configuration pragma causes all -occurrences of the mechanism types Descriptor[_xxx] to be treated as -Short_Descriptor[_xxx]. This is helpful in porting legacy applications from a -32-bit environment to a 64-bit environment. This pragma is ignored for non-VMS -versions. +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 @unnumberedsec Pragma Simple_Storage_Pool_Type @@ -7096,7 +7154,7 @@ The meaning of a test case is that there is at least one context where that context, then @code{Ensures} holds when the subprogram returns. Mode @code{Nominal} indicates that the input context should also satisfy the precondition of the subprogram, and the output context should also satisfy its -postcondition. More @code{Robustness} indicates that the precondition and +postcondition. Mode @code{Robustness} indicates that the precondition and postcondition of the subprogram should be ignored for this test case. @node Pragma Thread_Local_Storage @@ -7242,6 +7300,59 @@ pragma, making it language defined, and GNAT fully implements this extended 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 +@unnumberedsec Pragma Unevaluated_Use_Of_Old +@cindex Attribute Old +@cindex Attribute Loop_Entry +@cindex Unevaluated_Use_Of_Old +@findex Unevaluated_Use_Of_Old +@noindent +Syntax: + +@smallexample @c ada +pragma Unevaluated_Use_Of_Old (Error | Warn | Allow); +@end smallexample + +@noindent +This pragma controls the processing of attributes Old and Loop_Entry. +If either of these attributes is used in a potentially unevaluated +expression (e.g. the then or else parts of an if expression), then +normally this usage is considered illegal if the prefix of the attribute +is other than an entity name. The language requires this +behavior for Old, and GNAT copies the same rule for Loop_Entry. + +The reason for this rule is that otherwise, we can have a situation +where we save the Old value, and this results in an exception, even +though we might not evaluate the attribute. Consider this example: + +@smallexample @c ada +package UnevalOld is + K : Character; + procedure U (A : String; C : Boolean) -- ERROR + with Post => (if C then A(1)'Old = K else True); +end; +@end smallexample + +@noindent +If procedure U is called with a string with a lower bound of 2, and +C false, then an exception would be raised trying to evaluate A(1) +on entry even though the value would not be actually used. + +Although the rule guarantees against this possibility, it is sometimes +too restrictive. For example if we know that the string has a lower +bound of 1, then we will never raise an exception. +The pragma @code{Unevaluated_Use_Of_Old} can be +used to modify this behavior. If the argument is @code{Error} then an +error is given (this is the default RM behavior). If the argument is +@code{Warn} then the usage is allowed as legal but with a warning +that an exception might be raised. If the argument is @code{Allow} +then the usage is allowed as legal without generating a warning. + +This pragma may appear as a configuration pragma, or in a declarative +part or package specification. In the latter case it applies to +uses up to the end of the corresponding statement sequence or +sequence of package declarations. + @node Pragma Unimplemented_Unit @unnumberedsec Pragma Unimplemented_Unit @findex Unimplemented_Unit @@ -7952,9 +8063,13 @@ clause. * Aspect Initializes:: * Aspect Inline_Always:: * Aspect Invariant:: +* Aspect Invariant'Class:: +* Aspect Iterable:: * Aspect Linker_Section:: * Aspect Lock_Free:: +* Aspect No_Elaboration_Code_All:: * Aspect Object_Size:: +* Aspect Obsolescent:: * Aspect Part_Of:: * Aspect Persistent_BSS:: * Aspect Predicate:: @@ -8105,19 +8220,22 @@ between values in different systems. The MKS system is characterized by the following aspect: @smallexample @c ada - type Mks_Type is new Long_Long_Float - with - Dimension_System => ( - (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), - (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), - (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), - (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), - (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"), - (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), - (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + type Mks_Type is new Long_Long_Float with + Dimension_System => ( + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); @end smallexample @noindent +Note that in the above type definition, we use the symbol @code{@@} to +represent a theta character (avoiding the use of extended Latin-1 +characters in this context). + See section ``Performing Dimensionality Analysis in GNAT'' in the GNAT Users Guide for detailed examples of use of the dimension system. @@ -8171,6 +8289,43 @@ This aspect is equivalent to pragma @code{Invariant}. It is a synonym for the language defined aspect @code{Type_Invariant} except that it is separately controllable using pragma @code{Assertion_Policy}. +@node Aspect Invariant'Class +@unnumberedsec Aspect Invariant'Class +@findex Invariant'Class +@noindent +This aspect is equivalent to pragma @code{Type_Invariant_Class}. It is a +synonym for the language defined aspect @code{Type_Invariant'Class} except +that it is separately controllable using pragma @code{Assertion_Policy}. + +@node Aspect Iterable +@unnumberedsec Aspect Iterable +@findex Iterable +@noindent +This aspect is used in the GNAT-defined formal container packages, to provide +a light-weight mechanism for loops over such containers, without the overhead +imposed by the tampering checks of standard Ada2012 iterators. The value of the +aspect is a aggregate with four named components: First, Next, Has_Element, +and Element. The following is a typical example of use: + +@smallexample @c ada +type List is private with + Iterable => (First => First_Element, + Next => Advance, + Has_Element => Get_Element, + Element => List_Element); +@end smallexample +@itemize @bullet +@item The value denoted by @code{First} must denote a primitive operation of +the container type that returns a Cursor, which must a be a type declared in +the container package. +@item The value of @code{Next} is a primitive operation of the container type +that takes a cursor and yields a cursor. +@item @code{Has_Element} is an operation that applies to a cursor a yields an +element of the container. +@item @code{Element} is the type of the elements of the container type, and +thus the result of the function denoted by Has_Element. +@end itemize + @node Aspect Linker_Section @unnumberedsec Aspect Linker_Section @findex Linker_Section @@ -8183,6 +8338,13 @@ This aspect is equivalent to an @code{Linker_Section} pragma. @noindent This aspect is equivalent to pragma @code{Lock_Free}. +@node Aspect No_Elaboration_Code_All +@unnumberedsec Aspect No_Elaboration_Code_All +@findex No_Elaboration_Code_All +@noindent +This aspect is equivalent to a @code{pragma No_Elaboration_Code_All} +statement for a program unit. + @node Aspect Object_Size @unnumberedsec Aspect Object_Size @findex Object_Size @@ -8190,6 +8352,14 @@ This aspect is equivalent to pragma @code{Lock_Free}. This aspect is equivalent to an @code{Object_Size} attribute definition clause. +@node Aspect Obsolescent +@unnumberedsec Aspect Obsolescent +@findex Obsolsecent +@noindent +This aspect is equivalent to an @code{Obsolescent} pragma. 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 @unnumberedsec Aspect Part_Of @findex Part_Of @@ -8360,7 +8530,9 @@ In addition, Ada allows implementations to define additional attributes whose meaning is defined by the implementation. GNAT provides a number of these implementation-dependent attributes which can be used to extend and enhance the functionality of the compiler. This section of -the GNAT reference manual describes these additional attributes. +the GNAT reference manual describes these additional attributes. It also +describes additional implementation-dependent features of standard +language-defined attributes. Note that any program using these attributes may not be portable to other compilers (although GNAT implements this set of attributes on all @@ -8373,11 +8545,14 @@ consideration, you should minimize the use of these attributes. * Attribute Asm_Input:: * Attribute Asm_Output:: * Attribute AST_Entry:: +* Attribute Atomic_Always_Lock_Free:: * Attribute Bit:: * Attribute Bit_Position:: -* Attribute Compiler_Version:: * Attribute Code_Address:: +* Attribute Compiler_Version:: +* Attribute Constrained:: * Attribute Default_Bit_Order:: +* Attribute Default_Scalar_Storage_Order:: * Attribute Descriptor_Size:: * Attribute Elaborated:: * Attribute Elab_Body:: @@ -8388,14 +8563,18 @@ consideration, you should minimize the use of these attributes. * Attribute Enum_Rep:: * Attribute Enum_Val:: * Attribute Epsilon:: +* Attribute Fast_Math:: * Attribute Fixed_Value:: +* Attribute From_Any:: * Attribute Has_Access_Values:: * Attribute Has_Discriminants:: * Attribute Img:: * Attribute Integer_Value:: * Attribute Invalid_Value:: +* Attribute Iterable:: * Attribute Large:: * Attribute Library_Level:: +* Attribute Lock_Free:: * Attribute Loop_Entry:: * Attribute Machine_Size:: * Attribute Mantissa:: @@ -8403,6 +8582,7 @@ consideration, you should minimize the use of these attributes. * Attribute Mechanism_Code:: * Attribute Null_Parameter:: * Attribute Object_Size:: +* Attribute Old:: * Attribute Passed_By_Reference:: * Attribute Pool_Address:: * Attribute Range_Length:: @@ -8411,6 +8591,7 @@ consideration, you should minimize the use of these attributes. * Attribute Result:: * Attribute Safe_Emax:: * Attribute Safe_Large:: +* Attribute Safe_Small:: * Attribute Scalar_Storage_Order:: * Attribute Simple_Storage_Pool:: * Attribute Small:: @@ -8418,16 +8599,18 @@ consideration, you should minimize the use of these attributes. * Attribute Stub_Type:: * Attribute System_Allocator_Alignment:: * Attribute Target_Name:: -* Attribute Tick:: * Attribute To_Address:: +* Attribute To_Any:: * Attribute Type_Class:: +* Attribute Type_Key:: +* Attribute TypeCode:: * Attribute UET_Address:: * Attribute Unconstrained_Array:: * Attribute Universal_Literal_String:: * Attribute Unrestricted_Access:: * Attribute Update:: -* Attribute Valid_Scalars:: * Attribute VADS_Size:: +* Attribute Valid_Scalars:: * Attribute Value_Size:: * Attribute Wchar_T_Size:: * Attribute Word_Size:: @@ -8498,6 +8681,16 @@ pragma @code{Extend_System (Aux_DEC)}). This value enables the given entry to be called when an AST occurs. For further details, refer to the @cite{DEC Ada Language Reference Manual}, section 9.12a. +@node Attribute Atomic_Always_Lock_Free +@unnumberedsec Attribute Atomic_Always_Lock_Free +@findex Atomic_Always_Lock_Free +@noindent + +The prefix of the @code{Atomic_Always_Lock_Free} attribute is a type. +The result is a Boolean value which is True if the type has discriminants, +and False otherwise. The result indicate whether atomic operations are +supported by the target for the given type. + @node Attribute Bit @unnumberedsec Attribute Bit @findex Bit @@ -8537,15 +8730,6 @@ type @code{Universal_Integer}. The value depends only on the field @var{C} and is independent of the alignment of the containing record @var{R}. -@node Attribute Compiler_Version -@unnumberedsec Attribute Compiler_Version -@findex Compiler_Version -@noindent -@code{Standard'Compiler_Version} (@code{Standard} is the only allowed -prefix) yields a static string identifying the version of the compiler -being used to compile the unit containing the attribute reference. A -typical result would be something like "@value{EDITION} @i{version} (20090221)". - @node Attribute Code_Address @unnumberedsec Attribute Code_Address @findex Code_Address @@ -8585,6 +8769,28 @@ generated code of the specified subprogram, which may or may not be the same value as is returned by the corresponding @code{'Address} attribute. +@node Attribute Compiler_Version +@unnumberedsec Attribute Compiler_Version +@findex Compiler_Version +@noindent +@code{Standard'Compiler_Version} (@code{Standard} is the only allowed +prefix) yields a static string identifying the version of the compiler +being used to compile the unit containing the attribute reference. A +typical result would be something like +"@value{EDITION} @value{gnat_version} (20090221)". + +@node Attribute Constrained +@unnumberedsec Attribute Constrained +@findex Constrained +@noindent +In addition to the usage of this attribute in the Ada RM, @code{GNAT} +also permits the use of the @code{'Constrained} attribute +in a generic template +for any type, including types without discriminants. The value of this +attribute in the generic instance when applied to a scalar type or a +record type without discriminants is always @code{True}. This usage is +compatible with older Ada compilers, including notably DEC Ada. + @node Attribute Default_Bit_Order @unnumberedsec Attribute Default_Bit_Order @cindex Big endian @@ -8597,6 +8803,18 @@ as a @code{Pos} value (0 for @code{High_Order_First}, 1 for @code{Low_Order_First}). This is used to construct the definition of @code{Default_Bit_Order} in package @code{System}. +@node Attribute Default_Scalar_Storage_Order +@unnumberedsec Attribute Default_Scalar_Storage_Order +@cindex Big endian +@cindex Little endian +@findex Default_Scalar_Storage_Order +@noindent +@code{Standard'Default_Scalar_Storage_Order} (@code{Standard} is the only +permissible prefix), provides the current value of the default scalar storage +order (as specified using pragma @code{Default_Scalar_Storage_Order}, or +equal to @code{Default_Bit_Order} if unspecified) as a +@code{System.Bit_Order} value. This is a static attribute. + @node Attribute Descriptor_Size @unnumberedsec Attribute Descriptor_Size @cindex Descriptor @@ -8765,6 +8983,14 @@ The @code{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 +@unnumberedsec Attribute Fast_Math +@findex Fast_Math +@noindent +@code{Standard'Fast_Math} (@code{Standard} is the only allowed +prefix) yields a static Boolean value that is True if pragma +@code{Fast_Math} is active, and False otherwise. + @node Attribute Fixed_Value @unnumberedsec Attribute Fixed_Value @findex Fixed_Value @@ -8792,6 +9018,13 @@ that there are full range checks, to ensure that the result is in range. This attribute is primarily intended for use in implementation of the input-output functions for fixed-point values. +@node Attribute From_Any +@unnumberedsec Attribute From_Any +@findex From_Any +@noindent +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 @unnumberedsec Attribute Has_Access_Values @cindex Access values, testing for @@ -8884,6 +9117,12 @@ uninitialized value of the type if pragma Initialize_Scalars is used, including the ability to modify the value with the binder -Sxx flag and relevant environment variables at run time. +@node Attribute Iterable +@unnumberedsec Attribute Iterable +@findex Iterable +@noindent +Equivalent to Aspect Iterable. + @node Attribute Large @unnumberedsec Attribute Large @cindex Ada 83 attributes @@ -8917,6 +9156,13 @@ package Gen is end Gen; @end smallexample +@node Attribute Lock_Free +@unnumberedsec Attribute Lock_Free +@findex Lock_Free +@noindent +@code{P'Lock_Free}, where P is a protected object, returns True if a +pragma @code{Lock_Free} applies to P. + @node Attribute Loop_Entry @unnumberedsec Attribute Loop_Entry @findex Loop_Entry @@ -8991,28 +9237,8 @@ meaning the first parameter) of @var{subprogram}. The code returned is: by copy (value) @item 2 by reference -@item 3 -by descriptor (default descriptor class) -@item 4 -by descriptor (UBS: unaligned bit string) -@item 5 -by descriptor (UBSB: aligned bit string with arbitrary bounds) -@item 6 -by descriptor (UBA: unaligned bit array) -@item 7 -by descriptor (S: string, also scalar access type parameter) -@item 8 -by descriptor (SB: string with arbitrary bounds) -@item 9 -by descriptor (A: contiguous array) -@item 10 -by descriptor (NCA: non-contiguous array) @end table -@noindent -Values from 3 through 10 are only relevant to Digital OpenVMS implementations. -@cindex OpenVMS - @node Attribute Null_Parameter @unnumberedsec Attribute Null_Parameter @cindex Zero address, passing @@ -9101,6 +9327,18 @@ generates the diagnostic shown above. Similar additional checks are performed in other contexts requiring statically matching subtypes. +@node Attribute Old +@unnumberedsec Attribute Old +@findex Old +@noindent +In addition to the usage of @code{Old} defined in the Ada 2012 RM (usage +within @code{Post} aspect), GNAT also permits the use of this attribute +in implementation defined pragmas @code{Postcondition}, +@code{Contract_Cases} and @code{Test_Case}. Also usages of +@code{Old} which would be illegal according to the Ada 2012 RM +definition are allowed under control of +implementation defined pragma @code{Unevaluated_Use_Of_Old}. + @node Attribute Passed_By_Reference @unnumberedsec Attribute Passed_By_Reference @cindex Parameters, when passed by reference @@ -9243,6 +9481,15 @@ The @code{Safe_Large} attribute is provided for compatibility with Ada 83. See the Ada 83 reference manual for an exact description of the semantics of this attribute. +@node Attribute Safe_Small +@unnumberedsec Attribute Safe_Small +@cindex Ada 83 attributes +@findex Safe_Small +@noindent +The @code{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. + @node Attribute Scalar_Storage_Order @unnumberedsec Attribute Scalar_Storage_Order @cindex Endianness @@ -9251,7 +9498,9 @@ this attribute. @noindent For every array or record type @var{S}, the representation attribute @code{Scalar_Storage_Order} denotes the order in which storage elements -that make up scalar components are ordered within S: +that make up scalar components are ordered within S. The value given must +be a static expression of type System.Bit_Order. The following is an example +of the use of this feature: @smallexample @c ada -- Component type definitions @@ -9285,19 +9534,22 @@ that make up scalar components are ordered within S: -- the former is used. @end smallexample +@noindent Other properties are as for standard representation attribute @code{Bit_Order}, as defined by Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}. -For a record type @var{S}, if @code{@var{S}'Scalar_Storage_Order} is -specified explicitly, it shall be equal to @code{@var{S}'Bit_Order}. Note: +For a record type @var{T}, if @code{@var{T}'Scalar_Storage_Order} is +specified explicitly, it shall be equal to @code{@var{T}'Bit_Order}. Note: this means that if a @code{Scalar_Storage_Order} attribute definition clause is not confirming, then the type's @code{Bit_Order} shall be specified explicitly and set to the same value. -For a record extension, the derived type shall have the same scalar storage -order as the parent type. +Derived types inherit an explicitly set scalar storage order from their parent +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 @var{S} is of a record or array type, then that type shall +If a component of @var{T} is of a record or array type, then that type must also have a @code{Scalar_Storage_Order} attribute definition clause. A component of a record or array type that is a packed array, or that @@ -9337,6 +9589,11 @@ are relaxed. Instead, the following rules apply: @end itemize +If no scalar storage order is specified for a type (either directly, or by +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 @code{Default_Scalar_Storage_Order}. + @node Attribute Simple_Storage_Pool @unnumberedsec Attribute Simple_Storage_Pool @cindex Storage pool, simple @@ -9459,13 +9716,6 @@ for the current compilation. For GCC implementations, this is the standard gcc target name without the terminating slash (for example, GNAT 5.0 on windows yields "i586-pc-mingw32msv"). -@node Attribute Tick -@unnumberedsec Attribute Tick -@findex Tick -@noindent -@code{Standard'Tick} (@code{Standard} is the only permissible prefix) -provides the same value as @code{System.Tick}, - @node Attribute To_Address @unnumberedsec Attribute To_Address @findex To_Address @@ -9486,6 +9736,13 @@ argument is static). The argument must be in the range modular manner (e.g. -1 means the same as 16#FFFF_FFFF# on a 32 bits machine). +@node Attribute To_Any +@unnumberedsec Attribute To_Any +@findex To_Any +@noindent +This internal attribute is used for the generation of remote subprogram +stubs in the context of the Distributed Systems Annex. + @node Attribute Type_Class @unnumberedsec Attribute Type_Class @findex Type_Class @@ -9514,6 +9771,22 @@ Protected types yield the value @code{Type_Class_Task}, which thus 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 +@unnumberedsec Attribute Type_Key +@findex Type_Key +@noindent +The @code{Type_Key} attribute is applicable to a type or subtype and +yields a value of type Standard.String containing encoded information +about the type or subtype. This provides improved compatibility with +other implementations that support this attribute. + +@node Attribute TypeCode +@unnumberedsec Attribute TypeCode +@findex TypeCode +@noindent +This internal attribute is used for the generation of remote subprogram +stubs in the context of the Distributed Systems Annex. + @node Attribute UET_Address @unnumberedsec Attribute UET_Address @findex UET_Address @@ -9848,6 +10121,16 @@ be determined at compile time that the prefix of the attribute has no scalar parts (e.g., if the prefix is of an access type, an interface type, an undiscriminated task type, or an undiscriminated protected type). +For scalar types, @code{Valid_Scalars} is equivalent to @code{Valid}. The use +of this attribute is not permitted for @code{Unchecked_Union} types for which +in general it is not possible to determine the values of the discriminants. + +Note: @code{Valid_Scalars} can generate a lot of code, especially in the case +of a large variant record. If the attribute is called in many places in the +same program applied to objects of the same type, it can reduce program size +to write a function with a single use of the attribute, and then call that +function from multiple places. + @node Attribute VADS_Size @unnumberedsec Attribute VADS_Size @cindex @code{Size}, VADS compatibility @@ -10270,7 +10553,7 @@ statements (raise with no operand) are not permitted. [GNAT] This restriction ensures at compile time that no stream operations for types Exception_Id or Exception_Occurrence are used. This also makes it impossible to pass exceptions to or from a partition with this restriction -in a distributed environment. If this exception is active, then the generated +in a distributed environment. If this restriction is active, the generated code is simplified by omitting the otherwise-required global registration of exceptions when they are declared. @@ -10786,16 +11069,16 @@ type @code{Character}). forbidden in SPARK 2005 are not present. Error messages related to SPARK restriction have the form: +@smallexample +violation of restriction "SPARK_05" at + +@end smallexample + @findex SPARK The restriction @code{SPARK} is recognized as a synonym for @code{SPARK_05}. This is retained for historical compatibility purposes (and an unconditional warning will be generated -for its use, advising replacement by @code{SPARK}. - -@smallexample -violation of restriction "SPARK" at - -@end smallexample +for its use, advising replacement by @code{SPARK}). This is not a replacement for the semantic checks performed by the SPARK Examiner tool, as the compiler currently only deals with code, @@ -10811,7 +11094,7 @@ This restriction can be useful in providing an initial filter for code developed using SPARK 2005, or in examining legacy code to see how far it is from meeting SPARK restrictions. -The list below summarises the checks that are performed when this +The list below summarizes the checks that are performed when this restriction is in force: @itemize @bullet @item No block statements @@ -10871,7 +11154,7 @@ restriction is in force: @item Modular type modulus must be power of 2 @item Base not allowed on subtype mark @item Unary operators not allowed on modular types (except not) -@item Non-tagged record cannot be null +@item Untagged record cannot be null @item No class-wide operations @item Initialization expressions must respect SPARK restrictions @item Non-static ranges not allowed except in iteration schemes @@ -11822,9 +12105,7 @@ convention. Any declarations useful for interfacing to any language on the given hardware architecture should be provided directly in @code{Interfaces}. @end cartouche -Followed. An additional package not defined -in the Ada Reference Manual is @code{Interfaces.CPP}, used -for interfacing to C++. +Followed. @sp 1 @cartouche @@ -14321,6 +14602,8 @@ There are no restrictions on pragma @code{Restrictions}. @menu * Intrinsic Operators:: +* Compilation_Date:: +* Compilation_Time:: * Enclosing_Entity:: * Exception_Information:: * Exception_Message:: @@ -14378,12 +14661,34 @@ of the differing types @code{Int1} and @code{Int2}. It is also possible to specify such operators for private types, if the full views are appropriate arithmetic types. +@node Compilation_Date +@section Compilation_Date +@cindex Compilation_Date +@noindent +This intrinsic subprogram is used in the implementation of the +library package @code{GNAT.Source_Info}. The only useful use of the +intrinsic import in this case is the one in this unit, so an +application program should simply call the function +@code{GNAT.Source_Info.Compilation_Date} to obtain the date of +the current compilation (in local time format MMM DD YYYY). + +@node Compilation_Time +@section Compilation_Time +@cindex Compilation_Time +@noindent +This intrinsic subprogram is used in the implementation of the +library package @code{GNAT.Source_Info}. The only useful use of the +intrinsic import in this case is the one in this unit, so an +application program should simply call the function +@code{GNAT.Source_Info.Compilation_Time} to obtain the time of +the current compilation (in local time format HH:MM:SS). + @node Enclosing_Entity @section Enclosing_Entity @cindex Enclosing_Entity @noindent This intrinsic subprogram is used in the implementation of the -library routine @code{GNAT.Source_Info}. The only useful use of the +library package @code{GNAT.Source_Info}. The only useful use of the intrinsic import in this case is the one in this unit, so an application program should simply call the function @code{GNAT.Source_Info.Enclosing_Entity} to obtain the name of @@ -14394,7 +14699,7 @@ the current subprogram, package, task, entry, or protected subprogram. @cindex Exception_Information' @noindent This intrinsic subprogram is used in the implementation of the -library routine @code{GNAT.Current_Exception}. The only useful +library package @code{GNAT.Current_Exception}. The only useful use of the intrinsic import in this case is the one in this unit, so an application program should simply call the function @code{GNAT.Current_Exception.Exception_Information} to obtain @@ -14405,7 +14710,7 @@ the exception information associated with the current exception. @cindex Exception_Message @noindent This intrinsic subprogram is used in the implementation of the -library routine @code{GNAT.Current_Exception}. The only useful +library package @code{GNAT.Current_Exception}. The only useful use of the intrinsic import in this case is the one in this unit, so an application program should simply call the function @code{GNAT.Current_Exception.Exception_Message} to obtain @@ -14416,7 +14721,7 @@ the message associated with the current exception. @cindex Exception_Name @noindent This intrinsic subprogram is used in the implementation of the -library routine @code{GNAT.Current_Exception}. The only useful +library package @code{GNAT.Current_Exception}. The only useful use of the intrinsic import in this case is the one in this unit, so an application program should simply call the function @code{GNAT.Current_Exception.Exception_Name} to obtain @@ -14427,7 +14732,7 @@ the name of the current exception. @cindex File @noindent This intrinsic subprogram is used in the implementation of the -library routine @code{GNAT.Source_Info}. The only useful use of the +library package @code{GNAT.Source_Info}. The only useful use of the intrinsic import in this case is the one in this unit, so an application program should simply call the function @code{GNAT.Source_Info.File} to obtain the name of the current @@ -14438,7 +14743,7 @@ file. @cindex Line @noindent This intrinsic subprogram is used in the implementation of the -library routine @code{GNAT.Source_Info}. The only useful use of the +library package @code{GNAT.Source_Info}. The only useful use of the intrinsic import in this case is the one in this unit, so an application program should simply call the function @code{GNAT.Source_Info.Line} to obtain the number of the current @@ -14508,6 +14813,7 @@ source file location. * Handling of Records with Holes:: * Enumeration Clauses:: * Address Clauses:: +* Use of Address Clauses for Memory-Mapped I/O:: * Effect of Convention on Representation:: * Conventions and Anonymous Access Types:: * Determining the Representations chosen by GNAT:: @@ -16301,6 +16607,64 @@ end Overwrite_Array; then the program compiles without the warning and when run will generate the output @code{X was not clobbered}. +@node Use of Address Clauses for Memory-Mapped I/O +@section Use of Address Clauses for Memory-Mapped I/O +@cindex Memory-mapped I/O + +A common pattern is to use an address clause to map an atomic variable to +a location in memory that corresponds to a memory-mapped I/O operation or +operations, for example: + +@smallexample @c ada + type Mem_Word is record + A,B,C,D : Byte; + end record; + pragma Atomic (Mem_Word); + for Mem_Word_Size use 32; + + Mem : Mem_Word; + for Mem'Address use some-address; + ... + Temp := Mem; + Temp.A := 32; + Mem := Temp; +@end smallexample + +@noindent +For a full access (reference or modification) of the variable (Mem) in +this case, as in the above examples, GNAT guarantees that the entire atomic +word will be accessed. It is not clear whether the RM requires this. For +example in the above, can the compiler reference only the Mem.A field as +an optimization? Whatever the answer to this question is, GNAT makes the +guarantee that for such a reference, the entire word is read or written. + +A problem arises with a component access such as: + +@smallexample @c ada + Mem.A := 32; +@end smallexample + +@noindent +Note that the component A is not declared as atomic. This means that it is +not clear what this assignment means. It could correspond to full word read +and write as given in the first example, or on architectures that supported +such an operation it might be a single byte store instruction. The RM does +not have anything to say in this situation, and GNAT does not make any +guarantee. The code generated may vary from target to target. GNAT will issue +a warning in such a case: + +@smallexample @c ada + Mem.A := 32; + | + >>> warning: access to non-atomic component of atomic array, + may cause unexpected accesses to atomic object +@end smallexample + +@noindent +It is best to be explicit in this situation, by either declaring the +components to be atomic if you want the byte store, or explicitly writing +the full word access sequence if that is what the hardware requires. + @node Effect of Convention on Representation @section Effect of Convention on Representation @cindex Convention, effect on representation @@ -18619,6 +18983,7 @@ of GNAT, and will generate a warning message. * GNAT.Expect (g-expect.ads):: * GNAT.Expect.TTY (g-exptty.ads):: * GNAT.Float_Control (g-flocon.ads):: +* GNAT.Formatted_String (g-forstr.ads):: * GNAT.Heap_Sort (g-heasor.ads):: * GNAT.Heap_Sort_A (g-hesora.ads):: * GNAT.Heap_Sort_G (g-hesorg.ads):: @@ -18674,7 +19039,6 @@ of GNAT, and will generate a warning message. * GNAT.Wide_Wide_String_Split (g-zistsp.ads):: * Interfaces.C.Extensions (i-cexten.ads):: * Interfaces.C.Streams (i-cstrea.ads):: -* Interfaces.CPP (i-cpp.ads):: * Interfaces.Packed_Decimal (i-pacdec.ads):: * Interfaces.VxWorks (i-vxwork.ads):: * Interfaces.VxWorks.IO (i-vxwoio.ads):: @@ -19545,6 +19909,18 @@ mode required for correct semantic operation in Ada. Some third party 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) +@section @code{GNAT.Formatted_String} (@file{g-forstr.ads}) +@cindex @code{GNAT.Formatted_String} (@file{g-forstr.ads}) +@cindex Formatted String + +@noindent +Provides support for C/C++ printf() formatted strings. The format is +copied from the printf() routine and should therefore gives identical +output. Some generic routines are provided to be able to use types +derived from Integer, Float or enumerations as values for the +formatted string. + @node GNAT.Heap_Sort (g-heasor.ads) @section @code{GNAT.Heap_Sort} (@file{g-heasor.ads}) @cindex @code{GNAT.Heap_Sort} (@file{g-heasor.ads}) @@ -19645,7 +20021,9 @@ a modified version of the Blum-Blum-Shub generator. @cindex Message Digest MD5 @noindent -Implements the MD5 Message-Digest Algorithm as described in RFC 1321. +Implements the MD5 Message-Digest Algorithm as described in RFC 1321, and +the HMAC-MD5 message authentication function as described in RFC 2104 and +FIPS PUB 198. @node GNAT.Memory_Dump (g-memdum.ads) @section @code{GNAT.Memory_Dump} (@file{g-memdum.ads}) @@ -19781,7 +20159,8 @@ port. This is only supported on GNU/Linux and Windows. @noindent Implements the SHA-1 Secure Hash Algorithm as described in FIPS PUB 180-3 -and RFC 3174. +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) @section @code{GNAT.SHA224} (@file{g-sha224.ads}) @@ -19789,7 +20168,9 @@ and RFC 3174. @cindex Secure Hash Algorithm SHA-224 @noindent -Implements the SHA-224 Secure Hash Algorithm as described in FIPS PUB 180-3. +Implements the SHA-224 Secure Hash Algorithm as described in FIPS PUB 180-3, +and the HMAC-SHA224 message authentication function as described +in RFC 2104 and FIPS PUB 198. @node GNAT.SHA256 (g-sha256.ads) @section @code{GNAT.SHA256} (@file{g-sha256.ads}) @@ -19797,7 +20178,9 @@ Implements the SHA-224 Secure Hash Algorithm as described in FIPS PUB 180-3. @cindex Secure Hash Algorithm SHA-256 @noindent -Implements the SHA-256 Secure Hash Algorithm as described in FIPS PUB 180-3. +Implements the SHA-256 Secure Hash Algorithm as described in FIPS PUB 180-3, +and the HMAC-SHA256 message authentication function as described +in RFC 2104 and FIPS PUB 198. @node GNAT.SHA384 (g-sha384.ads) @section @code{GNAT.SHA384} (@file{g-sha384.ads}) @@ -19805,7 +20188,9 @@ Implements the SHA-256 Secure Hash Algorithm as described in FIPS PUB 180-3. @cindex Secure Hash Algorithm SHA-384 @noindent -Implements the SHA-384 Secure Hash Algorithm as described in FIPS PUB 180-3. +Implements the SHA-384 Secure Hash Algorithm as described in FIPS PUB 180-3, +and the HMAC-SHA384 message authentication function as described +in RFC 2104 and FIPS PUB 198. @node GNAT.SHA512 (g-sha512.ads) @section @code{GNAT.SHA512} (@file{g-sha512.ads}) @@ -19813,7 +20198,9 @@ Implements the SHA-384 Secure Hash Algorithm as described in FIPS PUB 180-3. @cindex Secure Hash Algorithm SHA-512 @noindent -Implements the SHA-512 Secure Hash Algorithm as described in FIPS PUB 180-3. +Implements the SHA-512 Secure Hash Algorithm as described in FIPS PUB 180-3, +and the HMAC-SHA512 message authentication function as described +in RFC 2104 and FIPS PUB 198. @node GNAT.Signals (g-signal.ads) @section @code{GNAT.Signals} (@file{g-signal.ads}) @@ -19843,7 +20230,9 @@ for the LynxOS@ cross port. @noindent Provides subprograms that give access to source code information known at -compile time, such as the current file name and line number. +compile time, such as the current file name and line number. Also provides +subprograms yielding the date and time of the current compilation (like the +C macros @code{__DATE__} and @code{__TIME__}) @node GNAT.Spelling_Checker (g-speche.ads) @section @code{GNAT.Spelling_Checker} (@file{g-speche.ads}) @@ -20108,17 +20497,6 @@ to C libraries. This package is a binding for the most commonly used operations on C streams. -@node Interfaces.CPP (i-cpp.ads) -@section @code{Interfaces.CPP} (@file{i-cpp.ads}) -@cindex @code{Interfaces.CPP} (@file{i-cpp.ads}) -@cindex C++ interfacing -@cindex Interfacing, to C++ - -@noindent -This package provides facilities for use in interfacing to C++. It -is primarily intended to be used in connection with automated tools -for the generation of C++ interfaces. - @node Interfaces.Packed_Decimal (i-pacdec.ads) @section @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads}) @cindex @code{Interfaces.Packed_Decimal} (@file{i-pacdec.ads}) @@ -20558,7 +20936,7 @@ including machine instructions in a subprogram. The two features are similar, and both are closely related to the mechanism provided by the asm instruction in the GNU C compiler. Full understanding and use of the facilities in this package requires understanding the asm -instruction, see @ref{Extended Asm,,, gcc, Using the GNU Compiler +instruction, see @ref{Extended Asm,,, gcc, Using the GNU Compiler Collection (GCC)}. Calls to the function @code{Asm} and the procedure @code{Asm} have identical @@ -20592,7 +20970,7 @@ The @code{Asm_Output} attribute denotes a function that takes two parameters. The first is a string, the second is the name of a variable of the type designated by the attribute prefix. The first (string) argument is required to be a static expression and designates the -constraint (@pxref{Constraints,,, gcc, Using the GNU Compiler +constraint (@pxref{Constraints,,, gcc, Using the GNU Compiler Collection (GCC)}) for the parameter (e.g.@: what kind of register is required). The second argument is the variable to be written or updated with the @@ -20629,7 +21007,7 @@ expression, and is a space or comma separated list of names of registers that must be considered destroyed as a result of the @code{Asm} call. If this argument is the null string (the default value), then the code generator assumes that no additional registers are destroyed. -In addition to registers, the special clobbers @code{memory} and +In addition to registers, the special clobbers @code{memory} and @code{cc} as described in the GNU C docs are both supported. The fifth argument, not present in the above example, called the @@ -20641,7 +21019,7 @@ will still be generated, even if none of the outputs are used. @xref{Volatile,,, gcc, Using the GNU Compiler Collection (GCC)}, for the full description. Generally it is strongly advisable to use Volatile for any ASM statement -that is missing either input or output operands or to avoid unwanted +that is missing either input or output operands or to avoid unwanted optimizations. A warning is generated if this advice is not followed. No support is provided for GNU C's @code{asm goto} feature. diff --git a/main/gcc/ada/gnat_ugn.texi b/main/gcc/ada/gnat_ugn.texi index 04633a23920..913330d7370 100644 --- a/main/gcc/ada/gnat_ugn.texi +++ b/main/gcc/ada/gnat_ugn.texi @@ -75,10 +75,6 @@ Texts. A copy of the license is included in the section entitled @c This command inhibits page breaks, so long examples in a @cartouche can @c lead to large, ugly patches of empty space on a page. @c -@c NOTE: This file should be submitted to xgnatugn with either the vms flag -@c or the unw flag set. The unw flag covers topics for both Unix and -@c Windows. -@c @c oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo @set NOW January 2007 @@ -91,15 +87,7 @@ Texts. A copy of the license is included in the section entitled @set FSFEDITION @set EDITION GNAT -@ifset unw @set PLATFORM -@set TITLESUFFIX -@end ifset - -@ifset vms -@set PLATFORM OpenVMS -@set TITLESUFFIX for OpenVMS -@end ifset @c @ovar(ARG) @c ---------- @@ -116,7 +104,7 @@ Texts. A copy of the license is included in the section entitled @c of the @ovar macro have been expanded inline. -@settitle @value{EDITION} User's Guide @value{TITLESUFFIX} +@settitle @value{EDITION} User's Guide @dircategory GNU Ada tools @direntry * @value{EDITION} User's Guide: (gnat_ugn). @value{PLATFORM} @@ -130,12 +118,6 @@ Texts. A copy of the license is included in the section entitled @titlepage @title @value{EDITION} User's Guide -@ifset vms -@sp 1 -@flushright -@titlefont{@i{@value{PLATFORM}}} -@end flushright -@end ifset @sp 2 @@ -181,19 +163,15 @@ AdaCore@* * The Cross-Referencing Tools gnatxref and gnatfind:: @ifclear FSFEDITION * The GNAT Pretty-Printer gnatpp:: -@ifclear vms * The Ada-to-XML converter gnat2xml:: -@end ifclear * The GNAT Metrics Tool gnatmetric:: @end ifclear * File Name Krunching with gnatkr:: * Preprocessing with gnatprep:: * The GNAT Library Browser gnatls:: * Cleaning Up with gnatclean:: -@ifclear vms * GNAT and Libraries:: * Using the GNU make Utility:: -@end ifclear * Memory Management Issues:: * Stack Related Facilities:: @ifclear FSFEDITION @@ -204,19 +182,15 @@ AdaCore@* * Performing Dimensionality Analysis in GNAT:: * Generating Ada Bindings for C and C++ headers:: * Other Utility Programs:: -@ifclear vms * Code Coverage and Profiling:: -@end ifclear * Running and Debugging Ada Programs:: -@ifset vms -* Compatibility with HP Ada:: -@end ifset * Platform-Specific Information for the Run-Time Libraries:: * Example of Binder Output File:: * Elaboration Order Handling in GNAT:: * Overflow Check Handling in GNAT:: * Conditional Compilation:: * Inline Assembler:: +* Writing Portable Fixed-Point Declarations:: * Compatibility and Porting Guide:: * Microsoft Windows Topics:: * Mac OS Topics:: @@ -229,17 +203,9 @@ AdaCore@* @unnumbered About This Guide @noindent -@ifset vms -This guide describes the use of @value{EDITION}, -a compiler and software development toolset for the full Ada -programming language, implemented on OpenVMS for HP's Alpha and -Integrity server (I64) platforms. -@end ifset -@ifclear vms This guide describes the use of @value{EDITION}, a compiler and software development toolset for the full Ada programming language. -@end ifclear It documents the features of the compiler and tools, and explains how to use them to build Ada applications. @@ -342,12 +308,10 @@ comment placement, and other elements of program presentation style. @end ifclear @ifclear FSFEDITION -@ifclear vms @item @ref{The Ada-to-XML converter gnat2xml}, shows how to convert Ada source code into XML. @end ifclear -@end ifclear @ifclear FSFEDITION @item @@ -376,7 +340,6 @@ on the corresponding sources files, and consistency of compilations. @ref{Cleaning Up with gnatclean}, describes @code{gnatclean}, a utility to delete files that are produced by the compiler, binder and linker. -@ifclear vms @item @ref{GNAT and Libraries}, describes the process of creating and using Libraries with GNAT. It also describes how to recompile the GNAT run-time @@ -385,18 +348,15 @@ library. @item @ref{Using the GNU make Utility}, describes some techniques for using the GNAT toolset in Makefiles. -@end ifclear @item @ref{Memory Management Issues}, describes some useful predefined storage pools and in particular the GNAT Debug Pool facility, which helps detect incorrect memory references. -@ifclear vms @ifclear FSFEDITION It also describes @command{gnatmem}, a utility that monitors dynamic allocation and deallocation and helps detect ``memory leaks''. @end ifclear -@end ifclear @item @ref{Stack Related Facilities}, describes some useful tools associated with @@ -432,27 +392,14 @@ generate automatically Ada bindings from C and C++ headers. @ref{Other Utility Programs}, discusses several other GNAT utilities, including @code{gnathtml}. -@ifclear vms @item @ref{Code Coverage and Profiling}, describes how to perform a structural coverage and profile the execution of Ada programs. -@end ifclear @item @ref{Running and Debugging Ada Programs}, describes how to run and debug Ada programs. -@ifset vms -@item -@ref{Compatibility with HP Ada}, details the compatibility of GNAT with -HP Ada 83 @footnote{``HP Ada'' refers to the legacy product originally -developed by Digital Equipment Corporation and currently supported by HP.} -for OpenVMS Alpha. This product was formerly known as DEC Ada, -@cindex DEC Ada -and for -historical compatibility reasons, the relevant libraries still use the -DEC prefix. -@end ifset @item @ref{Platform-Specific Information for the Run-Time Libraries}, @@ -481,11 +428,14 @@ both with Ada in general and with GNAT facilities in particular. in an Ada program. @item +@ref{Writing Portable Fixed-Point Declarations}, gives some guidance on +defining portable fixed-point types. + +@item @ref{Compatibility and Porting Guide}, contains sections on compatibility of GNAT with other Ada development environments (including Ada 83 systems), to assist in porting code from those environments. -@ifset unw @item @ref{Microsoft Windows Topics}, presents information relevant to the Microsoft Windows platform. @@ -493,7 +443,6 @@ Microsoft Windows platform. @item @ref{Mac OS Topics}, presents information relevant to Apple's OS X platform. -@end ifset @end itemize @c ************************************************* @@ -526,7 +475,6 @@ documents: Reference Manual}, which contains all reference material for the GNAT implementation of Ada. -@ifset unw @item @cite{Using the GNAT Programming Studio}, which describes the GPS Integrated Development Environment. @@ -534,7 +482,6 @@ Integrated Development Environment. @item @cite{GNAT Programming Studio Tutorial}, which introduces the main GPS features through examples. -@end ifset @item @cite{Ada 95 Reference Manual}, which contains reference @@ -546,17 +493,11 @@ material for the Ada 2005 programming language. @item @xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, -@ifset vms -in the GNU:[DOCS] directory, -@end ifset for all details on the use of the GNU source-level debugger. @item @xref{Top,, The extensible self-documenting text editor, emacs, GNU Emacs Manual}, -@ifset vms -located in the GNU:[DOCS] directory if the EMACS kit is installed, -@end ifset for full information on the extensible editor and programming environment Emacs. @@ -608,12 +549,10 @@ you see them in the manual. If your system uses some other prompt, then the command will appear with the @code{$} replaced by whatever prompt character you are using. -@ifset unw Full file names are shown with the ``@code{/}'' character 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 ``@code{\}'' character should be used instead. -@end ifset @c **************************** @node Getting Started with GNAT @@ -622,7 +561,6 @@ the ``@code{\}'' character should be used instead. @noindent This chapter describes some simple ways of using GNAT to build executable Ada programs. -@ifset unw @ref{Running GNAT}, through @ref{Using the gnatmake Utility}, show how to use the command line environment. @ref{Introduction to GPS}, provides a brief @@ -633,19 +571,13 @@ other programming languages, comprehensive browsing features, and many other capabilities. For information on GPS please refer to @cite{Using the GNAT Programming Studio}. -@end ifset @menu * Running GNAT:: * Running a Simple Ada Program:: * Running a Program with Multiple Units:: * Using the gnatmake Utility:: -@ifset vms -* Editing with Emacs:: -@end ifset -@ifclear vms * Introduction to GPS:: -@end ifclear @end menu @node Running GNAT @@ -683,11 +615,11 @@ standard format text file: @smallexample @c ada @cartouche -with Ada.Text_IO; use Ada.Text_IO; -procedure Hello is -begin +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{procedure} Hello @b{is} +@b{begin} Put_Line ("Hello WORLD!"); -end Hello; +@b{end} Hello; @end cartouche @end smallexample @@ -722,12 +654,10 @@ C. It assumes that you have given it an Ada program if the file extension is either @file{.ads} or @file{.adb}, and it will then call the GNAT compiler to compile the specified file. -@ifclear vms The @option{-c} switch is required. It tells @command{gcc} to only do a compilation. (For C programs, @command{gcc} can also do linking, but this capability is not used directly for Ada programs, so the @option{-c} switch must always be present.) -@end ifclear This compile command generates a file @file{hello.o}, which is the object @@ -767,7 +697,7 @@ The result is an executable program called @file{hello}, which can be run by entering: @smallexample -$ ^hello^RUN HELLO^ +$ hello @end smallexample @noindent @@ -795,32 +725,32 @@ main program, and the spec and body of a package: @smallexample @c ada @cartouche @group -package Greetings is - procedure Hello; - procedure Goodbye; -end Greetings; - -with Ada.Text_IO; use Ada.Text_IO; -package body Greetings is - procedure Hello is - begin +@b{package} Greetings @b{is} + @b{procedure} Hello; + @b{procedure} Goodbye; +@b{end} Greetings; + +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{package} @b{body} Greetings @b{is} + @b{procedure} Hello @b{is} + @b{begin} Put_Line ("Hello WORLD!"); - end Hello; + @b{end} Hello; - procedure Goodbye is - begin + @b{procedure} Goodbye @b{is} + @b{begin} Put_Line ("Goodbye WORLD!"); - end Goodbye; -end Greetings; + @b{end} Goodbye; +@b{end} Greetings; @end group @group -with Greetings; -procedure Gmain is -begin +@b{with} Greetings; +@b{procedure} Gmain @b{is} +@b{begin} Greetings.Hello; Greetings.Goodbye; -end Gmain; +@b{end} Gmain; @end group @end cartouche @end smallexample @@ -910,7 +840,7 @@ Invoke it using either one of the following forms: @smallexample $ gnatmake gmain.adb -$ gnatmake ^gmain^GMAIN^ +$ gnatmake gmain @end smallexample @noindent @@ -918,7 +848,7 @@ The argument is the name of the file containing the main program; you may omit the extension. @command{gnatmake} examines the environment, automatically recompiles any files that need recompiling, and binds and links the resulting set of object files, -generating the executable file, @file{^gmain^GMAIN.EXE^}. +generating the executable file, @file{gmain}. In a large program, it can be extremely helpful to use @command{gnatmake}, because working out by hand what needs to be recompiled can be difficult. @@ -933,36 +863,7 @@ found by the compiler on a previous compilation, which may possibly be wrong when sources change. @command{gnatmake} determines the exact set of dependencies from scratch each time it is run. -@ifset vms -@node Editing with Emacs -@section Editing with Emacs -@cindex Emacs - -@noindent -Emacs is an extensible self-documenting text editor that is available in a -separate VMSINSTAL kit. - -Invoke Emacs by typing @kbd{Emacs} at the command prompt. To get started, -click on the Emacs Help menu and run the Emacs Tutorial. -In a character cell terminal, Emacs help is invoked with @kbd{Ctrl-h} (also -written as @kbd{C-h}), and the tutorial by @kbd{C-h t}. - -Documentation on Emacs and other tools is available in Emacs under the -pull-down menu button: @code{Help - Info}. After selecting @code{Info}, -use the middle mouse button to select a topic (e.g.@: Emacs). - -In a character cell terminal, do @kbd{C-h i} to invoke info, and then @kbd{m} -(stands for menu) followed by the menu item desired, as in @kbd{m Emacs}, to -get to the Emacs manual. -Help on Emacs is also available by typing @kbd{HELP EMACS} at the DCL command -prompt. - -The tutorial is highly recommended in order to learn the intricacies of Emacs, -which is sufficiently extensible to provide for a complete programming -environment and shell for the sophisticated user. -@end ifset -@ifclear vms @node Introduction to GPS @section Introduction to GPS @cindex GPS (GNAT Programming Studio) @@ -1083,11 +984,11 @@ Type the following text @smallexample @c ada @group -with Ada.Text_IO; use Ada.Text_IO; -procedure Hello is -begin +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{procedure} Hello @b{is} +@b{begin} Put_Line("Hello from GPS!"); -end Hello; +@b{end} Hello; @end group @end smallexample @@ -1149,19 +1050,19 @@ Select @code{File}, then @code{New}, and type in the following program: @smallexample @c ada @group -with Ada.Text_IO; use Ada.Text_IO; -procedure Example is +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{procedure} Example @b{is} Line : String (1..80); N : Natural; -begin +@b{begin} Put_Line("Type a line of text at each prompt; an empty line to exit"); - loop + @b{loop} Put(": "); Get_Line (Line, N); Put_Line (Line (1..N) ); - exit when N=0; - end loop; -end Example; + @b{exit} @b{when} N=0; + @b{end} @b{loop}; +@b{end} Example; @end group @end smallexample @@ -1271,7 +1172,6 @@ The value of @code{N} will be 0, and the program will terminate. The console window will disappear. @end enumerate @end enumerate -@end ifclear @node The GNAT Compilation Model @chapter The GNAT Compilation Model @@ -1289,14 +1189,9 @@ The console window will disappear. * The Ada Library Information Files:: * Binding an Ada Program:: * Mixed Language Programming:: -@ifclear vms * Building Mixed Ada & C++ Programs:: * Comparison between GNAT and C/C++ Compilation Models:: -@end ifclear * Comparison between GNAT and Conventional Ada Library Models:: -@ifset vms -* Placement of temporary files:: -@end ifset @end menu @noindent @@ -1378,7 +1273,8 @@ of the compiler (@pxref{Character Set Control}). @menu * Latin-1:: * Other 8-Bit Codes:: -* Wide Character Encodings:: +* Wide_Character Encodings:: +* Wide_Wide_Character Encodings:: @end menu @node Latin-1 @@ -1471,8 +1367,8 @@ equivalences that are recognized, see the file @file{csets.adb} in the GNAT compiler sources. You will need to obtain a full source release of GNAT to obtain this file. -@node Wide Character Encodings -@subsection Wide Character Encodings +@node Wide_Character Encodings +@subsection Wide_Character Encodings @noindent GNAT allows wide character codes to appear in character and string @@ -1545,8 +1441,9 @@ where the @var{xxx} bits correspond to the left-padded bits of the are represented as ASCII bytes and all upper half characters and other wide characters are represented as sequences of upper-half (The full UTF-8 scheme allows for encoding 31-bit characters as -6-byte sequences, but in this implementation, all UTF-8 sequences -of four or more bytes length will be treated as illegal). +6-byte sequences, and in the following section on wide wide +characters, the use of these sequences is documented). + @item Brackets Coding In this encoding, a wide character is represented by the following eight character sequence: @@ -1564,8 +1461,8 @@ Brackets coding for upper half characters. For example, the code @code{16#A3#} can be represented as @code{[``A3'']}. This scheme is compatible with use of the full Wide_Character set, -and is also the method used for wide character encoding in the standard -ACVC (Ada Compiler Validation Capability) test suite distributions. +and is also the method used for wide character encoding in some standard +ACATS (Ada Conformity Assessment Test Suite) test suite distributions. @end table @@ -1574,6 +1471,60 @@ 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 use of the upper half of the Latin-1 set. +@node Wide_Wide_Character Encodings +@subsection Wide_Wide_Character Encodings + +@noindent +GNAT allows wide wide character codes to appear in character and string +literals, and also optionally in identifiers, by means of the following +possible encoding schemes: + +@table @asis + +@item UTF-8 Coding +A wide character is represented using +UCS Transformation Format 8 (UTF-8) as defined in Annex R of ISO +10646-1/Am.2. Depending on the character value, the representation +of character codes with values greater than 16#FFFF# is a +is a four, five, or six byte sequence: + +@smallexample +@iftex +@leftskip=.7cm +@end iftex +16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx + 10xxxxxx +16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + 10xxxxxx 10xxxxxx +16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx + 10xxxxxx 10xxxxxx 10xxxxxx +@end smallexample + +@noindent +where the @var{xxx} bits correspond to the left-padded bits of the +32-bit character value. + +@item Brackets Coding +In this encoding, a wide wide character is represented by the following ten or +twelve byte character sequence: + +@smallexample +[ " a b c d e f " ] +[ " a b c d e f g h " ] +@end smallexample + +@noindent +Where @code{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 +@code{16#001F_4567#}. + +This scheme is compatible with use of the full Wide_Wide_Character set, +and is also the method used for wide wide character encoding in some standard +ACATS (Ada Conformity Assessment Test Suite) test suite distributions. + +@end table + @node File Naming Rules @section File Naming Rules @@ -1581,27 +1532,17 @@ use of the upper half of the Latin-1 set. The default file name is determined by the name of the unit that the file contains. The name is formed by taking the full expanded name of the unit and replacing the separating dots with hyphens and using -^lowercase^uppercase^ for all letters. +lowercase for all letters. An exception arises if the file name generated by the above rules starts with one of the characters -@ifset vms -@samp{A}, @samp{G}, @samp{I}, or @samp{S}, -@end ifset -@ifclear vms @samp{a}, @samp{g}, @samp{i}, or @samp{s}, -@end ifclear and the second character is a -minus. In this case, the character ^tilde^dollar sign^ is used in place +minus. In this case, the character tilde is used in place of the minus. The reason for this special rule is to avoid clashes with the standard names for child units of the packages System, Ada, Interfaces, and GNAT, which use the prefixes -@ifset vms -@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-}, -@end ifset -@ifclear vms @samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-}, -@end ifclear respectively. The file extension is @file{.ads} for a spec and @@ -1623,7 +1564,7 @@ Func.Spec (child package spec) Func.Spec (child package body) @item main-sub.adb Sub (subunit of Main) -@item ^a~bad.adb^A$BAD.ADB^ +@item a~bad.adb A.Bad (child package body) @end table @@ -1673,9 +1614,9 @@ The form of this pragma is as shown in the following examples: @smallexample @c ada @cartouche -pragma Source_File_Name (My_Utilities.Stacks, +@b{pragma} Source_File_Name (My_Utilities.Stacks, Spec_File_Name => "myutilst_a.ada"); -pragma Source_File_name (My_Utilities.Stacks, +@b{pragma} Source_File_name (My_Utilities.Stacks, Body_File_Name => "myutilst.ada"); @end cartouche @end smallexample @@ -1695,7 +1636,6 @@ For more details on how the @file{gnat.adc} file is created and used see @ref{Handling of Configuration Pragmas}. @cindex @file{gnat.adc} -@ifclear vms GNAT allows completely arbitrary file names to be specified using the source file name pragma. However, if the file name specified has an extension other than @file{.ads} or @file{.adb} it is necessary to use @@ -1706,7 +1646,6 @@ of the language, here @code{ada}, as in: @smallexample $ gcc -c -x ada peculiar_file_name.sim @end smallexample -@end ifclear @noindent @command{gnatmake} handles non-standard file names in the usual manner (the @@ -1733,17 +1672,17 @@ alternative scheme for naming is specified by the use of @cindex Source_File_Name pragma @smallexample @c ada -pragma Source_File_Name ( +@b{pragma} Source_File_Name ( Spec_File_Name => FILE_NAME_PATTERN @r{[},Casing => CASING_SPEC@r{]} @r{[},Dot_Replacement => STRING_LITERAL@r{]}); -pragma Source_File_Name ( +@b{pragma} Source_File_Name ( Body_File_Name => FILE_NAME_PATTERN @r{[},Casing => CASING_SPEC@r{]} @r{[},Dot_Replacement => STRING_LITERAL@r{]}); -pragma Source_File_Name ( +@b{pragma} Source_File_Name ( Subunit_File_Name => FILE_NAME_PATTERN @r{[},Casing => CASING_SPEC@r{]} @r{[},Dot_Replacement => STRING_LITERAL@r{]}); @@ -1760,7 +1699,7 @@ systematically for this asterisk. The optional parameter whether the unit name is to be all upper-case letters, all lower-case letters, or mixed-case. If no @code{Casing} parameter is used, then the default is all -^lower-case^upper-case^. +lower-case. The optional @code{Dot_Replacement} string is used to replace any periods that occur in subunit or child unit names. If no @code{Dot_Replacement} @@ -1813,9 +1752,9 @@ bodies end with @file{.2.ada}. GNAT will follow this scheme if the following two pragmas appear: @smallexample @c ada -pragma Source_File_Name +@b{pragma} Source_File_Name (Spec_File_Name => "*.1.ada"); -pragma Source_File_Name +@b{pragma} Source_File_Name (Body_File_Name => "*.2.ada"); @end smallexample @@ -1824,9 +1763,9 @@ The default GNAT scheme is actually implemented by providing the following default pragmas internally: @smallexample @c ada -pragma Source_File_Name +@b{pragma} Source_File_Name (Spec_File_Name => "*.ads", Dot_Replacement => "-"); -pragma Source_File_Name +@b{pragma} Source_File_Name (Body_File_Name => "*.adb", Dot_Replacement => "-"); @end smallexample @@ -1841,15 +1780,15 @@ Ada 83 compiler, but it seems reasonable to extend this scheme to use the same double underscore separator for child units. @smallexample @c ada -pragma Source_File_Name +@b{pragma} Source_File_Name (Spec_File_Name => "*_.ADA", Dot_Replacement => "__", Casing = Uppercase); -pragma Source_File_Name +@b{pragma} Source_File_Name (Body_File_Name => "*.ADA", Dot_Replacement => "__", Casing = Uppercase); -pragma Source_File_Name +@b{pragma} Source_File_Name (Subunit_File_Name => "*.SEP", Dot_Replacement => "__", Casing = Uppercase); @@ -2169,7 +2108,7 @@ procedure My_Main is -- Declare an Ada procedure spec for Print_Num, then use -- C function print_num for the implementation. procedure Print_Num (Num : Integer); - pragma Import (C, Print_Num, "print_num"); + pragma Import (C, Print_Num, "print_num"; begin Print_Num (Get_Num); @@ -2181,15 +2120,15 @@ end My_Main; To build this example, first compile the foreign language files to generate object files: @smallexample -^gcc -c file1.c^gcc -c FILE1.C^ -^gcc -c file2.c^gcc -c FILE2.C^ +gcc -c file1.c +gcc -c file2.c @end smallexample @item Then, compile the Ada units to produce a set of object files and ALI files: @smallexample -gnatmake ^-c^/ACTIONS=COMPILE^ my_main.adb +gnatmake -c my_main.adb @end smallexample @item @@ -2284,22 +2223,22 @@ The build procedure for this application is similar to the last example's. First, compile the foreign language files to generate object files: @smallexample -^gcc -c main.c^gcc -c main.c^ +gcc -c main.c @end smallexample @item Next, compile the Ada units to produce a set of object files and ALI files: @smallexample -gnatmake ^-c^/ACTIONS=COMPILE^ unit1.adb -gnatmake ^-c^/ACTIONS=COMPILE^ unit2.adb +gnatmake -c unit1.adb +gnatmake -c unit2.adb @end smallexample @item Run the Ada binder on every generated ALI file. Make sure to use the @option{-n} option to specify a foreign main program: @smallexample -gnatbind ^-n^/NOMAIN^ unit1.ali unit2.ali +gnatbind -n unit1.ali unit2.ali @end smallexample @item @@ -2316,7 +2255,7 @@ This procedure yields a binary executable called @file{exec_file}. Depending on the circumstances (for example when your non-Ada main object does not provide symbol @code{main}), you may also need to instruct the GNAT linker not to include the standard startup objects by passing the -@option{^-nostartfiles^/NOSTART_FILES^} switch to @command{gnatlink}. +@option{-nostartfiles} switch to @command{gnatlink}. @node Calling Conventions @subsection Calling Conventions @@ -2422,7 +2361,6 @@ Equivalent to C. @item External Equivalent to C. -@ifclear vms @findex C++ @cindex Interfacing to C++ @cindex Convention C++ @@ -2430,7 +2368,6 @@ Equivalent to C. This stands for C++. For most purposes this is identical to C. See the separate description of the specialized GNAT pragmas relating to C++ interfacing for further details. -@end ifclear @findex Fortran @cindex Interfacing to Fortran @@ -2465,12 +2402,12 @@ types). This simplifies the definition of operations that use type checking to perform dimensional checks: @smallexample @c ada -type Distance is new Long_Float; -type Time is new Long_Float; -type Velocity is new Long_Float; -function "/" (D : Distance; T : Time) - return Velocity; -pragma Import (Intrinsic, "/"); +@b{type} Distance @b{is} @b{new} Long_Float; +@b{type} Time @b{is} @b{new} Long_Float; +@b{type} Velocity @b{is} @b{new} Long_Float; +@b{function} "/" (D : Distance; T : Time) + @b{return} Velocity; +@b{pragma} Import (Intrinsic, "/"); @end smallexample @noindent @@ -2486,8 +2423,8 @@ available. A typical example is the set of ``__builtin'' functions exposed by the GCC back-end, as in the following example: @smallexample @c ada - function builtin_sqrt (F : Float) return Float; - pragma Import (Intrinsic, builtin_sqrt, "__builtin_sqrtf"); + @b{function} builtin_sqrt (F : Float) @b{return} Float; + @b{pragma} Import (Intrinsic, builtin_sqrt, "__builtin_sqrtf"); @end smallexample Most of the GCC builtins are accessible this way, and as for other @@ -2498,7 +2435,6 @@ expectations. @noindent -@ifset unw @findex Stdcall @cindex Convention Stdcall @item Stdcall @@ -2517,7 +2453,6 @@ This is equivalent to @code{Stdcall}. @cindex Convention Win32 @item Win32 This is equivalent to @code{Stdcall}. -@end ifset @findex Stubbed @cindex Convention Stubbed @@ -2534,7 +2469,7 @@ identifier Fortran77 was used for Fortran, you can use the configuration pragma: @smallexample @c ada -pragma Convention_Identifier (Fortran77, Fortran); +@b{pragma} Convention_Identifier (Fortran77, Fortran); @end smallexample @noindent @@ -2542,7 +2477,6 @@ And from now on the identifier Fortran77 may be used as a convention identifier (for example in an @code{Import} pragma) with the same meaning as Fortran. -@ifclear vms @node Building Mixed Ada & C++ Programs @section Building Mixed Ada and C++ Programs @@ -2792,34 +2726,34 @@ A::A(void) @end smallexample @smallexample @c ada --- Ada sources -package body Simple_Cpp_Interface is +--@i{ Ada sources} +@b{package} @b{body} Simple_Cpp_Interface @b{is} - procedure Ada_Method2 (This : in out A; V : Integer) is - begin + @b{procedure} Ada_Method2 (This : @b{in} @b{out} A; V : Integer) @b{is} + @b{begin} Method1 (This); This.A_Value := V; - end Ada_Method2; + @b{end} Ada_Method2; -end Simple_Cpp_Interface; +@b{end} Simple_Cpp_Interface; -with System; -package Simple_Cpp_Interface is - type A is limited - record +@b{with} System; +@b{package} Simple_Cpp_Interface @b{is} + @b{type} A @b{is} @b{limited} + @b{record} Vptr : System.Address; O_Value : Integer; A_Value : Integer; - end record; - pragma Convention (C, A); + @b{end} @b{record}; + @b{pragma} Convention (C, A); - procedure Method1 (This : in out A); - pragma Import (C, Method1); + @b{procedure} Method1 (This : @b{in} @b{out} A); + @b{pragma} Import (C, Method1); - procedure Ada_Method2 (This : in out A; V : Integer); - pragma Export (C, Ada_Method2); + @b{procedure} Ada_Method2 (This : @b{in} @b{out} A; V : Integer); + @b{pragma} Export (C, Ada_Method2); -end Simple_Cpp_Interface; +@b{end} Simple_Cpp_Interface; @end smallexample @node Interfacing with C++ constructors @@ -2853,26 +2787,26 @@ information on how to build this spec is available in @ref{Generating Ada Bindings for C and C++ headers}). @smallexample @c ada -with Interfaces.C; use Interfaces.C; -package Pkg_Root is - type Root is tagged limited record +@b{with} Interfaces.C; @b{use} Interfaces.C; +@b{package} Pkg_Root @b{is} + @b{type} Root @b{is} @b{tagged} @b{limited} @b{record} A_Value : int; B_Value : int; - end record; - pragma Import (CPP, Root); + @b{end} @b{record}; + @b{pragma} Import (CPP, Root); - function Get_Value (Obj : Root) return int; - pragma Import (CPP, Get_Value); + @b{function} Get_Value (Obj : Root) @b{return} int; + @b{pragma} Import (CPP, Get_Value); - function Constructor return Root; - pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev"); + @b{function} Constructor @b{return} Root; + @b{pragma} Cpp_Constructor (Constructor, "_ZN4RootC1Ev"); - function Constructor (v : Integer) return Root; - pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei"); + @b{function} Constructor (v : Integer) @b{return} Root; + @b{pragma} Cpp_Constructor (Constructor, "_ZN4RootC1Ei"); - function Constructor (v, w : Integer) return Root; - pragma Cpp_Constructor (Constructor, "_ZN4RootC1Eii"); -end Pkg_Root; + @b{function} Constructor (v, w : Integer) @b{return} Root; + @b{pragma} Cpp_Constructor (Constructor, "_ZN4RootC1Eii"); +@b{end} Pkg_Root; @end smallexample On the Ada side the constructor is represented by a function (whose @@ -2922,9 +2856,9 @@ non-default C++ constructor that takes two integers. Let us derive the imported C++ class in the Ada side. For example: @smallexample @c ada - type DT is new Root with record + @b{type} DT @b{is} @b{new} Root @b{with} @b{record} C_Value : Natural := 2009; - end record; + @b{end} @b{record}; @end smallexample In this case the components DT inherited from the C++ side must be @@ -2936,7 +2870,7 @@ an aggregate of type DT, or by means of an extension aggregate. @smallexample @c ada Obj5 : DT; Obj6 : DT := Function_Returning_DT (50); - Obj7 : DT := (Constructor (30,40) with C_Value => 50); + Obj7 : DT := (Constructor (30,40) @b{with} C_Value => 50); @end smallexample The declaration of @code{Obj5} invokes the default constructors: the @@ -2952,15 +2886,15 @@ Let us now consider a record that has components whose type is imported from C++. For example: @smallexample @c ada - type Rec1 is limited record + @b{type} Rec1 @b{is} @b{limited} @b{record} Data1 : Root := Constructor (10); Value : Natural := 1000; - end record; + @b{end} @b{record}; - type Rec2 (D : Integer := 20) is limited record + @b{type} Rec2 (D : Integer := 20) @b{is} @b{limited} @b{record} Rec : Rec1; Data2 : Root := Constructor (D, 30); - end record; + @b{end} @b{record}; @end smallexample The initialization of an object of type @code{Rec2} will call the @@ -2977,8 +2911,8 @@ declarations. For example: @smallexample @c ada Obj9 : Rec2 := (Rec => (Data1 => Constructor (15, 16), - others => <>), - others => <>); + @b{others} => <>), + @b{others} => <>); @end smallexample The above declaration uses an Ada 2005 limited aggregate to @@ -2996,16 +2930,16 @@ In Ada 2005 we can use the extended return statement to build the Ada equivalent to C++ non-default constructors. For example: @smallexample @c ada - function Constructor (V : Integer) return Rec2 is - begin - return Obj : Rec2 := (Rec => (Data1 => Constructor (V, 20), - others => <>), - others => <>) do - -- Further actions required for construction of - -- objects of type Rec2 + @b{function} Constructor (V : Integer) @b{return} Rec2 @b{is} + @b{begin} + @b{return} Obj : Rec2 := (Rec => (Data1 => Constructor (V, 20), + @b{others} => <>), + @b{others} => <>) @b{do} + --@i{ Further actions required for construction of} + --@i{ objects of type Rec2} ... - end record; - end Constructor; + @b{end} @b{record}; + @b{end} Constructor; @end smallexample In this example the extended return statement construct is used to @@ -3077,46 +3011,46 @@ located in a file named @code{animals.h}. The following package demonstrates how to import these C++ declarations from the Ada side: @smallexample @c ada -with Interfaces.C.Strings; use Interfaces.C.Strings; -package Animals is - type Carnivore is interface; - pragma Convention (C_Plus_Plus, Carnivore); - function Number_Of_Teeth (X : Carnivore) - return Natural is abstract; - - type Domestic is interface; - pragma Convention (C_Plus_Plus, Set_Owner); - procedure Set_Owner - (X : in out Domestic; - Name : Chars_Ptr) is abstract; - - type Animal is tagged record +@b{with} Interfaces.C.Strings; @b{use} Interfaces.C.Strings; +@b{package} Animals @b{is} + @b{type} Carnivore @b{is} interface; + @b{pragma} Convention (C_Plus_Plus, Carnivore); + @b{function} Number_Of_Teeth (X : Carnivore) + @b{return} Natural @b{is} @b{abstract}; + + @b{type} Domestic @b{is} interface; + @b{pragma} Convention (C_Plus_Plus, Set_Owner); + @b{procedure} Set_Owner + (X : @b{in} @b{out} Domestic; + Name : Chars_Ptr) @b{is} @b{abstract}; + + @b{type} Animal @b{is} @b{tagged} @b{record} Age : Natural := 0; - end record; - pragma Import (C_Plus_Plus, Animal); + @b{end} @b{record}; + @b{pragma} Import (C_Plus_Plus, Animal); - procedure Set_Age (X : in out Animal; Age : Integer); - pragma Import (C_Plus_Plus, Set_Age); + @b{procedure} Set_Age (X : @b{in} @b{out} Animal; Age : Integer); + @b{pragma} Import (C_Plus_Plus, Set_Age); - function Age (X : Animal) return Integer; - pragma Import (C_Plus_Plus, Age); + @b{function} Age (X : Animal) @b{return} Integer; + @b{pragma} Import (C_Plus_Plus, Age); - type Dog is new Animal and Carnivore and Domestic with record + @b{type} Dog @b{is} @b{new} Animal @b{and} Carnivore @b{and} Domestic @b{with} @b{record} Tooth_Count : Natural; Owner : String (1 .. 30); - end record; - pragma Import (C_Plus_Plus, Dog); + @b{end} @b{record}; + @b{pragma} Import (C_Plus_Plus, Dog); - function Number_Of_Teeth (A : Dog) return Integer; - pragma Import (C_Plus_Plus, Number_Of_Teeth); + @b{function} Number_Of_Teeth (A : Dog) @b{return} Integer; + @b{pragma} Import (C_Plus_Plus, Number_Of_Teeth); - procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); - pragma Import (C_Plus_Plus, Set_Owner); + @b{procedure} Set_Owner (A : @b{in} @b{out} Dog; Name : Chars_Ptr); + @b{pragma} Import (C_Plus_Plus, Set_Owner); - function New_Dog return Dog; - pragma CPP_Constructor (New_Dog); - pragma Import (CPP, New_Dog, "_ZN3DogC2Ev"); -end Animals; + @b{function} New_Dog @b{return} Dog; + @b{pragma} CPP_Constructor (New_Dog); + @b{pragma} Import (CPP, New_Dog, "_ZN3DogC2Ev"); +@b{end} Animals; @end smallexample Thanks to the compatibility between GNAT run-time structures and the C++ ABI, @@ -3163,46 +3097,46 @@ Now let us define all the types and constructors on the Ada side and export them to C++, using the same hierarchy of our previous example: @smallexample @c ada -with Interfaces.C.Strings; -use Interfaces.C.Strings; -package Animals is - type Carnivore is interface; - pragma Convention (C_Plus_Plus, Carnivore); - function Number_Of_Teeth (X : Carnivore) - return Natural is abstract; - - type Domestic is interface; - pragma Convention (C_Plus_Plus, Set_Owner); - procedure Set_Owner - (X : in out Domestic; - Name : Chars_Ptr) is abstract; - - type Animal is tagged record +@b{with} Interfaces.C.Strings; +@b{use} Interfaces.C.Strings; +@b{package} Animals @b{is} + @b{type} Carnivore @b{is} interface; + @b{pragma} Convention (C_Plus_Plus, Carnivore); + @b{function} Number_Of_Teeth (X : Carnivore) + @b{return} Natural @b{is} @b{abstract}; + + @b{type} Domestic @b{is} interface; + @b{pragma} Convention (C_Plus_Plus, Set_Owner); + @b{procedure} Set_Owner + (X : @b{in} @b{out} Domestic; + Name : Chars_Ptr) @b{is} @b{abstract}; + + @b{type} Animal @b{is} @b{tagged} @b{record} Age : Natural := 0; - end record; - pragma Convention (C_Plus_Plus, Animal); + @b{end} @b{record}; + @b{pragma} Convention (C_Plus_Plus, Animal); - procedure Set_Age (X : in out Animal; Age : Integer); - pragma Export (C_Plus_Plus, Set_Age); + @b{procedure} Set_Age (X : @b{in} @b{out} Animal; Age : Integer); + @b{pragma} Export (C_Plus_Plus, Set_Age); - function Age (X : Animal) return Integer; - pragma Export (C_Plus_Plus, Age); + @b{function} Age (X : Animal) @b{return} Integer; + @b{pragma} Export (C_Plus_Plus, Age); - type Dog is new Animal and Carnivore and Domestic with record + @b{type} Dog @b{is} @b{new} Animal @b{and} Carnivore @b{and} Domestic @b{with} @b{record} Tooth_Count : Natural; Owner : String (1 .. 30); - end record; - pragma Convention (C_Plus_Plus, Dog); + @b{end} @b{record}; + @b{pragma} Convention (C_Plus_Plus, Dog); - function Number_Of_Teeth (A : Dog) return Integer; - pragma Export (C_Plus_Plus, Number_Of_Teeth); + @b{function} Number_Of_Teeth (A : Dog) @b{return} Integer; + @b{pragma} Export (C_Plus_Plus, Number_Of_Teeth); - procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); - pragma Export (C_Plus_Plus, Set_Owner); + @b{procedure} Set_Owner (A : @b{in} @b{out} Dog; Name : Chars_Ptr); + @b{pragma} Export (C_Plus_Plus, Set_Owner); - function New_Dog return Dog'Class; - pragma Export (C_Plus_Plus, New_Dog); -end Animals; + @b{function} New_Dog @b{return} Dog'Class; + @b{pragma} Export (C_Plus_Plus, New_Dog); +@b{end} Animals; @end smallexample Compared with our previous example the only difference is the use of @@ -3279,7 +3213,6 @@ simpler to use, but the C++ programmer has no control over elaboration. Where @code{gnatbind} might complain there was no valid order of elaboration, a C++ compiler would simply construct a program that malfunctioned at run time. -@end ifclear @node Comparison between GNAT and Conventional Ada Library Models @section Comparison between GNAT and Conventional Ada Library Models @@ -3344,35 +3277,6 @@ GNAT, simple source dependencies; in other words, there is only a set of rules saying what source files must be present when a file is compiled. -@ifset vms -@node Placement of temporary files -@section Placement of temporary files -@cindex Temporary files (user control over placement) - -@noindent -GNAT creates temporary files in the directory designated by the environment -variable @env{TMPDIR}. -(See the HP @emph{C RTL Reference Manual} on the function @code{getenv()} -for detailed information on how environment variables are resolved. -For most users the easiest way to make use of this feature is to simply -define @env{TMPDIR} as a job level logical name). -For example, if you wish to use a Ramdisk (assuming DECRAM is installed) -for compiler temporary files, then you can include something like the -following command in your @file{LOGIN.COM} file: - -@smallexample -$ define/job TMPDIR "/disk$scratchram/000000/temp/" -@end smallexample - -@noindent -If @env{TMPDIR} is not defined, then GNAT uses the directory designated by -@env{TMP}; if @env{TMP} is not defined, then GNAT uses the directory -designated by @env{TEMP}. -If none of these environment variables are defined then GNAT uses the -directory designated by the logical name @code{SYS$SCRATCH:} -(by default the user's home directory). If all else fails -GNAT uses the current directory for temporary files. -@end ifset @c ************************* @node Compiling with gcc @@ -3467,10 +3371,8 @@ $ gcc -c @r{[}@var{switches}@r{]} @file{file name} where @var{file name} is the name of the Ada file (usually having an extension @file{.ads} for a spec or @file{.adb} for a body). -@ifclear vms You specify the @option{-c} switch to tell @command{gcc} to compile, but not link, the file. -@end ifclear The result of a successful compilation is an object file, which has the same name as the source file but an extension of @file{.o} and an Ada Library Information (ALI) file, which also has the same name as the @@ -3503,7 +3405,7 @@ calls @code{gnat1} (the Ada compiler) twice to compile @file{x.adb} and @file{y.adb}. The compiler generates two object files @file{x.o} and @file{y.o} and the two ALI files @file{x.ali} and @file{y.ali}. -Any switches apply to all the files ^listed,^listed.^ +Any switches apply to all the files listed, @node Switches for gcc @section Switches for @command{gcc} @@ -3539,14 +3441,10 @@ compilation units. * Units to Sources Mapping Files:: * Integrated Preprocessing:: * Code Generation Control:: -@ifset vms -* Return Codes:: -@end ifset @end menu @table @option @c !sort! -@ifclear vms @cindex @option{-b} (@command{gcc}) @item -b @var{target} Compile your program to run on @var{target}, which is the name of a @@ -3572,7 +3470,6 @@ use @command{gcc} without a @option{-c} switch to compile and link in one step. In the case of GNAT, you cannot use this approach, because the binder must be run and @command{gcc} cannot be used to run the GNAT binder. -@end ifclear @item -fcallgraph-info@r{[}=su,da@r{]} @cindex @option{-fcallgraph-info} (@command{gcc}) @@ -3666,12 +3563,12 @@ See @ref{Stack Overflow Checking} for details. Makes the compiler output stack usage information for the program, on a per-subprogram basis. See @ref{Static Stack Usage Analysis} for details. -@item ^-g^/DEBUG^ -@cindex @option{^-g^/DEBUG^} (@command{gcc}) +@item -g +@cindex @option{-g} (@command{gcc}) Generate debugging information. This information is stored in the object file and copied from there to the final executable file by the linker, where it can be read by the debugger. You must use the -@option{^-g^/DEBUG^} switch if you plan on using the debugger. +@option{-g} switch if you plan on using the debugger. @item -gnat83 @cindex @option{-gnat83} (@command{gcc}) @@ -3707,7 +3604,10 @@ using the configuration pragma @code{Check_Policy}. In Ada 2012, it also activates all assertions defined in the RM as aspects: preconditions, postconditions, type invariants and (sub)type predicates. In all Ada modes, corresponding pragmas for type invariants and (sub)type predicates are -also activated. +also activated. The default is that all these assertions are disabled, +and have no effect, other than being checked for syntactic validity, and +in the case of subtype predicates, constructions such as membership tests +still test predicates even if assertions are turned off. @item -gnatA @cindex @option{-gnatA} (@command{gcc}) @@ -3755,19 +3655,14 @@ debug options. Certain debug options are relevant to applications programmers, and these are documented at appropriate points in this users guide. -@ifclear vms @item -gnatD @cindex @option{-gnatD[nn]} (@command{gcc}) -@end ifclear -@ifset vms -@item /XDEBUG /LXDEBUG=nnn -@end ifset Create expanded source files for source level debugging. This switch also suppress generation of cross-reference information (see @option{-gnatx}). Note that this switch is not allowed if a previous -gnatR switch has been given, since these two switches are not compatible. -@item ^-gnateA^/ALIASING_CHECK^ +@item -gnateA @cindex @option{-gnateA} (@command{gcc}) Check that the actual parameters of a subprogram call are not aliases of one another. To qualify as aliasing, the actuals must denote objects of a composite @@ -3804,9 +3699,7 @@ not share the memory location of @code{Obj}. @item -gnatec=@var{path} @cindex @option{-gnatec} (@command{gcc}) Specify a configuration pragma file -@ifclear vms (the equal sign is optional) -@end ifclear (@pxref{The Configuration Pragmas Files}). @item -gnateC @@ -3815,11 +3708,11 @@ Generate CodePeer messages in a compiler-like format. This switch is only effective if @option{-gnatcC} is also specified and requires an installation of CodePeer. -@item ^-gnated^/DISABLE_ATOMIC_SYNCHRONIZATION^ +@item -gnated @cindex @option{-gnated} (@command{gcc}) Disable atomic synchronization -@item ^-gnateD^/DATA_PREPROCESSING=^symbol@r{[}=@var{value}@r{]} +@item -gnateDsymbol@r{[}=@var{value}@r{]} @cindex @option{-gnateD} (@command{gcc}) Defines a symbol, associated with @var{value}, for preprocessing. (@pxref{Integrated Preprocessing}). @@ -3877,17 +3770,13 @@ This switch turns off the info messages about implicit elaboration pragmas. @item -gnatem=@var{path} @cindex @option{-gnatem} (@command{gcc}) Specify a mapping file -@ifclear vms (the equal sign is optional) -@end ifclear (@pxref{Units to Sources Mapping Files}). @item -gnatep=@var{file} @cindex @option{-gnatep} (@command{gcc}) Specify a preprocessing data file -@ifclear vms (the equal sign is optional) -@end ifclear (@pxref{Integrated Preprocessing}). @item -gnateP @@ -4019,12 +3908,12 @@ compiling sources developed on a later version of the compiler with an earlier version. Of course the earlier version must support this switch. -@item ^-gnateV^/PARAMETER_VALIDITY_CHECK^ +@item -gnateV @cindex @option{-gnateV} (@command{gcc}) Check that all actual parameters of a subprogram call are valid according to the rules of validity checking (@pxref{Validity Checking}). -@item ^-gnateY^/IGNORE_SUPPRESS_SYLE_CHECK_PRAGMAS^ +@item -gnateY @cindex @option{-gnateY} (@command{gcc}) Ignore all STYLE_CHECKS pragmas. Full legality checks are still carried out, but the pragmas have no effect @@ -4044,41 +3933,34 @@ attempt to suppress cascaded errors. @cindex @option{-gnatF} (@command{gcc}) Externals names are folded to all uppercase. -@item ^-gnatg^/GNAT_INTERNAL^ -@cindex @option{^-gnatg^/GNAT_INTERNAL^} (@command{gcc}) +@item -gnatg +@cindex @option{-gnatg} (@command{gcc}) Internal GNAT implementation mode. This should not be used for applications programs, it is intended only for use by the compiler and its run-time library. For documentation, see the GNAT sources. -Note that @option{^-gnatg^/GNAT_INTERNAL^} implies -@option{^-gnatw.ge^/WARNINGS=GNAT,ERRORS^} and -@option{^-gnatyg^/STYLE_CHECKS=GNAT^} +Note that @option{-gnatg} implies +@option{-gnatw.ge} and +@option{-gnatyg} so that all standard warnings and all standard style options are turned on. All warnings and style messages are treated as errors. -@ifclear vms @item -gnatG=nn @cindex @option{-gnatG[nn]} (@command{gcc}) -@end ifclear -@ifset vms -@item /EXPAND_SOURCE, /LEXPAND_SOURCE=nnn -@end ifset List generated expanded code in source form. -@item ^-gnath^/HELP^ -@cindex @option{^-gnath^/HELP^} (@command{gcc}) +@item -gnath +@cindex @option{-gnath} (@command{gcc}) Output usage information. The output is written to @file{stdout}. -@item ^-gnati^/IDENTIFIER_CHARACTER_SET=^@var{c} -@cindex @option{^-gnati^/IDENTIFIER_CHARACTER_SET^} (@command{gcc}) +@item -gnati@var{c} +@cindex @option{-gnati} (@command{gcc}) Identifier character set -@ifclear vms (@var{c}=1/2/3/4/8/9/p/f/n/w). -@end ifclear For details of the possible selections for @var{c}, see @ref{Character Set Control}. -@item ^-gnatI^/IGNORE_REP_CLAUSES^ -@cindex @option{^-gnatI^IGNORE_REP_CLAUSES^} (@command{gcc}) +@item -gnatI +@cindex @option{-gnatI} (@command{gcc}) Ignore representation clauses. When this switch is used, representation clauses are treated as comments. This is useful when initially porting code where you want to ignore rep clause @@ -4101,7 +3983,7 @@ Reformat error messages to fit on nn character lines @item -gnatk=@var{n} @cindex @option{-gnatk} (@command{gcc}) -Limit file names to @var{n} (1-999) characters ^(@code{k} = krunch)^^. +Limit file names to @var{n} (1-999) characters (@code{k} = krunch). @item -gnatl @cindex @option{-gnatl} (@command{gcc}) @@ -4145,6 +4027,13 @@ of GNAT other than the JGNAT, .NET or GNAAMP versions), then the use of Historically front end inlining was more extensive than the gcc back end inlining, but that is no longer the case. +@item -gnato0 +@cindex @option{-gnato0} (@command{gcc}) +Suppresses overflow checking. This causes the behavior of the compiler to +match the default for older versions where overflow checking was suppressed +by default. This is equivalent to having +@code{pragma Suppress (Overflow_Mode)} in a configuration pragma file. + @item -gnato?? @cindex @option{-gnato??} (@command{gcc}) Set default mode for handling generation of code to avoid intermediate @@ -4166,15 +4055,15 @@ cases; if two digits are given, then the first applies outside assertions, and the second within assertions. If no digits follow the @option{-gnato}, then it is equivalent to -@option{^-gnato11^/OVERFLOW_CHECKS=11^}, +@option{-gnato11}, causing all intermediate overflows to be handled in strict mode. This switch also causes arithmetic overflow checking to be performed -(as though pragma @code{Unsuppress (Overflow_Mode)} has been specified. +(as though @code{pragma Unsuppress (Overflow_Mode)} had been specified. The default if no option @option{-gnato} is given is that overflow handling is in @code{STRICT} mode (computations done using the base type), and that -overflow checking is suppressed. +overflow checking is enabled. Note that division by zero is a separate check that is not controlled by this switch (division by zero checking is on by default). @@ -4204,18 +4093,20 @@ Don't quit. Try semantics, even if parse errors. @item -gnatQ @cindex @option{-gnatQ} (@command{gcc}) Don't quit. Generate @file{ALI} and tree files even if illegalities. +Note that code generation is still suppressed in the presence of any +errors, so even with @option{-gnatQ} no object file is generated. @item -gnatr @cindex @option{-gnatr} (@command{gcc}) Treat pragma Restrictions as Restriction_Warnings. -@item ^-gnatR@r{[}0@r{/}1@r{/}2@r{/}3@r{[}s@r{]]}^/REPRESENTATION_INFO^ +@item -gnatR@r{[}0@r{/}1@r{/}2@r{/}3@r{[}s@r{]]} @cindex @option{-gnatR} (@command{gcc}) Output representation information for declared types and objects. Note that this switch is not allowed if a previous @code{-gnatD} switch has been given, since these two switches are not compatible. -@item ^-gnatRm[s]^/REPRESENTATION_INFO^ +@item -gnatRm[s] Output convention and parameter passing mechanisms for all subprograms. @item -gnats @@ -4230,8 +4121,8 @@ Print package Standard. @cindex @option{-gnatt} (@command{gcc}) Generate tree output file. -@item ^-gnatT^/TABLE_MULTIPLIER=^@var{nnn} -@cindex @option{^-gnatT^/TABLE_MULTIPLIER^} (@command{gcc}) +@item -gnatT@var{nnn} +@cindex @option{-gnatT} (@command{gcc}) All compiler tables start at @var{nnn} times usual starting size. @item -gnatu @@ -4250,22 +4141,17 @@ Verbose mode. Full error output with source lines to @file{stdout}. @cindex @option{-gnatV} (@command{gcc}) Control level of validity checking (@pxref{Validity Checking}). -@item ^-gnatw@var{xxx}^/WARNINGS=(@var{option}@r{[},@dots{}@r{]})^ -@cindex @option{^-gnatw^/WARNINGS^} (@command{gcc}) +@item -gnatw@var{xxx} +@cindex @option{-gnatw} (@command{gcc}) Warning mode where -^@var{xxx} is a string of option letters that^the list of options^ denotes +@var{xxx} is a string of option letters that denotes the exact warnings that are enabled or disabled (@pxref{Warning Message Control}). -@item ^-gnatW^/WIDE_CHARACTER_ENCODING=^@var{e} -@cindex @option{^-gnatW^/WIDE_CHARACTER_ENCODING^} (@command{gcc}) +@item -gnatW@var{e} +@cindex @option{-gnatW} (@command{gcc}) Wide character encoding method -@ifclear vms (@var{e}=n/h/u/s/e/8). -@end ifclear -@ifset vms -(@var{e}=@code{BRACKETS, NONE, HEX, UPPER, SHIFT_JIS, EUC, UTF8}) -@end ifset @item -gnatx @cindex @option{-gnatx} (@command{gcc}) @@ -4275,36 +4161,29 @@ Suppress generation of cross-reference information. @cindex @option{-gnatX} (@command{gcc}) Enable GNAT implementation extensions and latest Ada version. -@item ^-gnaty^/STYLE_CHECKS=(option,option@dots{})^ -@cindex @option{^-gnaty^/STYLE_CHECKS^} (@command{gcc}) +@item -gnaty +@cindex @option{-gnaty} (@command{gcc}) Enable built-in style checks (@pxref{Style Checking}). -@item ^-gnatz^/DISTRIBUTION_STUBS=^@var{m} -@cindex @option{^-gnatz^/DISTRIBUTION_STUBS^} (@command{gcc}) +@item -gnatz@var{m} +@cindex @option{-gnatz} (@command{gcc}) Distribution stub generation and compilation -@ifclear vms (@var{m}=r/c for receiver/caller stubs). -@end ifclear -@ifset vms -(@var{m}=@code{RECEIVER} or @code{CALLER} to specify the type of stubs -to be generated and compiled). -@end ifset -@item ^-I^/SEARCH=^@var{dir} -@cindex @option{^-I^/SEARCH^} (@command{gcc}) +@item -I@var{dir} +@cindex @option{-I} (@command{gcc}) @cindex RTL Direct GNAT to search the @var{dir} directory for source files needed by the current compilation (@pxref{Search Paths and the Run-Time Library (RTL)}). -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gcc}) +@item -I- +@cindex @option{-I-} (@command{gcc}) @cindex RTL 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 (@pxref{Search Paths and the Run-Time Library (RTL)}). -@ifclear vms @item -mbig-switch @cindex @option{-mbig-switch} (@command{gcc}) @cindex @code{case} statement (effect of @option{-mbig-switch} option) @@ -4321,7 +4200,6 @@ This switch is used in @command{gcc} to redirect the generated object file and its associated ALI file. Beware of this switch with GNAT, because it may cause the object file and ALI file to have different names which in turn may confuse the binder and the linker. -@end ifclear @item -nostdinc @cindex @option{-nostdinc} (@command{gcc}) @@ -4333,7 +4211,6 @@ Library (RTL) source files. Inhibit the search of the default location for the GNAT Run Time Library (RTL) ALI files. -@ifclear vms @c @item -O@ovar{n} @c Expanding @ovar macro inline (explanation in macro def comments) @item -O@r{[}@var{n}@r{]} @@ -4363,92 +4240,44 @@ Optimize space usage @noindent See also @ref{Optimization Levels}. -@end ifclear - -@ifset vms -@item /NOOPTIMIZE -@cindex @option{/NOOPTIMIZE} (@code{GNAT COMPILE}) -Equivalent to @option{/OPTIMIZE=NONE}. -This is the default behavior in the absence of an @option{/OPTIMIZE} -qualifier. - -@item /OPTIMIZE@r{[}=(keyword@r{[},@dots{}@r{]})@r{]} -@cindex @option{/OPTIMIZE} (@code{GNAT COMPILE}) -Selects the level of optimization for your program. The supported -keywords are as follows: -@table @code -@item ALL -Perform most optimizations, including those that -are expensive. -This is the default if the @option{/OPTIMIZE} qualifier is supplied -without keyword options. - -@item NONE -Do not do any optimizations. Same as @code{/NOOPTIMIZE}. - -@item SOME -Perform some optimizations, but omit ones that are costly. - -@item DEVELOPMENT -Same as @code{SOME}. -@item INLINING -Full optimization as in @option{/OPTIMIZE=ALL}, and also attempts -automatic inlining of small subprograms within a unit - -@item UNROLL_LOOPS -Try to unroll loops. This keyword may be specified together with -any keyword above other than @code{NONE}. Loop unrolling -usually, but not always, improves the performance of programs. - -@item SPACE -Optimize space usage -@end table - -@noindent -See also @ref{Optimization Levels}. -@end ifset -@ifclear vms @item -pass-exit-codes @cindex @option{-pass-exit-codes} (@command{gcc}) Catch exit codes from the compiler and use the most meaningful as exit status. -@end ifclear @item --RTS=@var{rts-path} @cindex @option{--RTS} (@command{gcc}) Specifies the default location of the runtime library. Same meaning as the equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@item ^-S^/ASM^ -@cindex @option{^-S^/ASM^} (@command{gcc}) -^Used in place of @option{-c} to^Used to^ +@item -S +@cindex @option{-S} (@command{gcc}) +Used in place of @option{-c} to cause the assembler source file to be -generated, using @file{^.s^.S^} as the extension, +generated, using @file{.s} as the extension, instead of the object file. This may be useful if you need to examine the generated assembly code. -@item ^-fverbose-asm^/VERBOSE_ASM^ -@cindex @option{^-fverbose-asm^/VERBOSE_ASM^} (@command{gcc}) -^Used in conjunction with @option{-S}^Used in place of @option{/ASM}^ +@item -fverbose-asm +@cindex @option{-fverbose-asm} (@command{gcc}) +Used in conjunction with @option{-S} to cause the generated assembly code file to be annotated with variable names, making it significantly easier to follow. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@command{gcc}) +@item -v +@cindex @option{-v} (@command{gcc}) Show commands generated by the @command{gcc} driver. Normally used only for debugging purposes or if you need to be sure what version of the compiler you are executing. -@ifclear vms @item -V @var{ver} @cindex @option{-V} (@command{gcc}) Execute @var{ver} version of the compiler. This is the @command{gcc} version, not the GNAT version. -@end ifclear -@item ^-w^/NO_BACK_END_WARNINGS^ +@item -w @cindex @option{-w} (@command{gcc}) Turn off warnings generated by the back end of the compiler. Use of this switch also causes the default for front end warnings to be set @@ -4457,7 +4286,6 @@ the options). @end table -@ifclear vms @c Combining qualifiers does not work on VMS You may combine a sequence of GNAT switches into a single switch. For example, the combined switch @@ -4473,7 +4301,6 @@ is equivalent to specifying the following sequence of switches: @smallexample -gnato -gnatf -gnati3 @end smallexample -@end ifclear @noindent The following restrictions apply to the combination of switches @@ -4490,14 +4317,13 @@ first in the string. @item The switches -^^@option{/DISTRIBUTION_STUBS=},^ + @option{-gnatzc} and @option{-gnatzr} may not be combined with any other switches, and only one of them may appear in the command line. @item The switch @option{-gnat-p} may not be combined with any other switch. -@ifclear vms @item Once a ``y'' appears in the string (that is a use of the @option{-gnaty} switch), then all further characters in the switch are interpreted @@ -4521,7 +4347,6 @@ as validity checking options (@pxref{Validity Checking}). @item Option ``em'', ``ec'', ``ep'', ``l='' and ``R'' must be the last options in a combined list of options. -@end ifclear @end itemize @node Output and Error Message Control @@ -4541,10 +4366,8 @@ e.adb:4:20: ";" should be "is" @noindent The first integer after the file name is the line number in the file, and the second integer is the column number within the line. -@ifclear vms @code{GPS} can parse the error messages and point to the referenced character. -@end ifclear The following switches provide control over the error message format: @@ -4553,9 +4376,7 @@ format: @item -gnatv @cindex @option{-gnatv} (@command{gcc}) @findex stdout -@ifclear vms The v stands for verbose. -@end ifclear The effect of this setting is to write long-format error messages to @file{stdout} (the standard output file. The same program compiled with the @@ -4579,9 +4400,7 @@ used the only source lines output are those with errors. @item -gnatl @cindex @option{-gnatl} (@command{gcc}) -@ifclear vms The @code{l} stands for list. -@end ifclear This switch causes a full listing of the file to be generated. In the case where a body is compiled, the corresponding spec is also listed, along @@ -4592,38 +4411,38 @@ body @file{p.adb} might look like: @cartouche Compiling: p.adb - 1. package body p is - 2. procedure a; - 3. procedure a is separate; - 4. begin - 5. null + 1. @b{package} @b{body} p @b{is} + 2. @b{procedure} a; + 3. @b{procedure} a @b{is} @b{separate}; + 4. @b{begin} + 5. @b{null} | >>> missing ";" - 6. end; + 6. @b{end}; Compiling: p.ads - 1. package p is - 2. pragma Elaborate_Body + 1. @b{package} p @b{is} + 2. @b{pragma} Elaborate_Body | >>> missing ";" - 3. end p; + 3. @b{end} p; Compiling: p-a.adb - 1. separate p + 1. @b{separate} p | >>> missing "(" - 2. procedure a is - 3. begin - 4. null + 2. @b{procedure} a @b{is} + 3. @b{begin} + 4. @b{null} | >>> missing ";" - 5. end; + 5. @b{end}; @end cartouche @end smallexample @@ -4634,15 +4453,15 @@ standard output is redirected, a brief summary is written to @file{stderr} (standard error) giving the number of error messages and warning messages generated. -@item ^-gnatl^/OUTPUT_FILE^=file -@cindex @option{^-gnatl^/OUTPUT_FILE^=fname} (@command{gcc}) +@item -gnatl=file +@cindex @option{-gnatl=fname} (@command{gcc}) This has the same effect as @option{-gnatl} except that the output is written to a file instead of to standard output. If the given name @file{fname} does not start with a period, then it is the full name of the file to be written. If @file{fname} is an extension, it is appended to the name of the file being compiled. For example, if -file @file{xyz.adb} is compiled with @option{^-gnatl^/OUTPUT_FILE^=.lst}, -then the output is written to file ^xyz.adb.lst^xyz.adb_lst^. +file @file{xyz.adb} is compiled with @option{-gnatl=.lst}, +then the output is written to file xyz.adb.lst. @item -gnatU @cindex @option{-gnatU} (@command{gcc}) @@ -4653,9 +4472,7 @@ of error messages. @item -gnatb @cindex @option{-gnatb} (@command{gcc}) -@ifclear vms The @code{b} stands for brief. -@end ifclear This switch causes GNAT to generate the brief format error messages to @file{stderr} (the standard error file) as well as the verbose @@ -4664,9 +4481,7 @@ format message or full listing (which as usual is written to @item -gnatm=@var{n} @cindex @option{-gnatm} (@command{gcc}) -@ifclear vms The @code{m} stands for maximum. -@end ifclear @var{n} is a decimal integer in the range of 1 to 999999 and limits the number of error or warning messages to be generated. For example, using @@ -4694,9 +4509,7 @@ Note that the equal sign is optional, so the switches @item -gnatf @cindex @option{-gnatf} (@command{gcc}) @cindex Error messages, suppressing -@ifclear vms The @code{f} stands for full. -@end ifclear Normally, the compiler suppresses error messages that are likely to be redundant. This switch causes all error messages to be generated. In particular, in the case of @@ -4748,9 +4561,7 @@ is longer than nn characters. @item -gnatq @cindex @option{-gnatq} (@command{gcc}) -@ifclear vms The @code{q} stands for quit (really ``don't quit''). -@end ifclear In normal operation mode, the compiler first parses the program and determines if there are any syntax errors. If there are, appropriate error messages are generated and compilation is immediately terminated. @@ -4980,17 +4791,25 @@ This switch activates most optional warning messages. See the remaining list in this section for details on optional warning messages that can be individually controlled. The warnings that are not turned on by this switch are: -@option{-gnatwd} (implicit dereferencing), -@option{-gnatwh} (hiding), + +@itemize +@option{-gnatwd} (implicit dereferencing) @option{-gnatw.d} (tag warnings with -gnatw switch) -@option{-gnatw.h} (holes (gaps) in record layouts) -@option{-gnatw.i} (overlapping actuals), -@option{-gnatw.k} (redefinition of names in standard), -@option{-gnatwl} (elaboration warnings), -@option{-gnatw.l} (inherited aspects), -@option{-gnatw.o} (warn on values set by out parameters ignored), +@option{-gnatwh} (hiding) +@option{-gnatw.h} (holes in record layouts) +@option{-gnatw.k} (redefinition of names in standard) +@option{-gnatwl} (elaboration warnings) +@option{-gnatw.l} (inherited aspects) +@option{-gnatw.n} (atomic synchronization) +@option{-gnatwo} (address clause overlay) +@option{-gnatw.o} (values set by out parameters ignored) +@option{-gnatw.s} (overridden size clause) @option{-gnatwt} (tracking of deleted conditional code) -and @option{-gnatw.u} (unordered enumeration), +@option{-gnatw.u} (unordered enumeration) +@option{-gnatw.w} (use of Warnings Off) +@option{-gnatw.y} (reasons for package needing body) +@end itemize + All other optional warnings are turned on. @item -gnatwA @@ -5102,8 +4921,6 @@ representation clause is present and has component clauses for the majority, but not all, of the components. A warning is given for each component for which no component clause is present. -This warning can also be turned on using @option{-gnatwa}. - @item -gnatw.C @emph{Suppress warnings on missing component clauses.} @cindex @option{-gnatwC} (@command{gcc}) @@ -5120,8 +4937,6 @@ enabled, access checks occur only at points where an explicit @code{.all} appears in the source code (assuming no warnings are generated as a result of this switch). The default is that such warnings are not generated. -Note that @option{-gnatwa} does not affect the setting of -this warning option. @item -gnatwD @emph{Suppress warnings on implicit dereferencing.} @@ -5183,6 +4998,8 @@ treated as errors. The warning string still appears, but the warning messages are counted as errors, and prevent the generation of an object file. Note that this is the only -gnatw switch that affects the handling of style check messages. +Note also that this switch has no effect on info (information) messages, which +are not treated as errors if this switch is present. @item -gnatw.e @emph{Activate every optional warning} @@ -5202,7 +5019,7 @@ been specifically designed according to specialized coding rules. @cindex Formals, unreferenced This switch causes a warning to be generated if a formal parameter is not referenced in the body of the subprogram. This warning can -also be turned on using @option{-gnatwa} or @option{-gnatwu}. The +also be turned on using @option{-gnatwu}. The default is that these warnings are not generated. @item -gnatwF @@ -5220,8 +5037,7 @@ formals. @cindex Pragmas, unrecognized This switch causes a warning to be generated if an unrecognized pragma is encountered. Apart from issuing this warning, the -pragma is ignored and has no effect. This warning can -also be turned on using @option{-gnatwa}. The default +pragma is ignored and has no effect. The default is that such warnings are issued (satisfying the Ada Reference Manual requirement that such warnings appear). @@ -5247,7 +5063,6 @@ 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. -Note that @option{-gnatwa} does not affect the setting of this warning option. @item -gnatwH @emph{Suppress warnings on hiding.} @@ -5262,7 +5077,6 @@ This switch activates warnings on component clauses in record representation clauses that leave holes (gaps) in the record layout. If this warning option is active, then record representation clauses should specify a contiguous layout, adding unused fill fields if needed. -Note that @option{-gnatwa} does not affect the setting of this warning option. @item -gnatw.H @emph{Suppress warnings on holes/gaps in records.} @@ -5276,13 +5090,12 @@ representation clauses that leave holes (haps) in the record layout. This switch activates warnings for a @code{with} of an internal GNAT implementation unit, defined as any unit from the @code{Ada}, @code{Interfaces}, @code{GNAT}, -^^@code{DEC},^ or @code{System} + or @code{System} hierarchies that is not documented in either the Ada Reference Manual or the GNAT Programmer's Reference Manual. Such units are intended only for internal implementation purposes and should not be @code{with}'ed by user programs. The default is that such warnings are generated -This warning can also be turned on using @option{-gnatwa}. @item -gnatwI @emph{Disable warnings on implementation units.} @@ -5295,8 +5108,7 @@ implementation unit. @cindex @option{-gnatw.i} (@command{gcc}) This switch enables a warning on statically detectable overlapping actuals in a subprogram call, when one of the actuals is an in-out parameter, and the -types of the actuals are not by-copy types. The warning is off by default, -and is not included under -gnatwa. +types of the actuals are not by-copy types. This warning is off by default. @item -gnatw.I @emph{Disable warnings on overlapping actuals.} @@ -5315,8 +5127,7 @@ case of Annex J, not all features are flagged. In particular use of the renamed packages (like @code{Text_IO}) and use of package @code{ASCII} are not flagged, since these are very common and would generate many annoying positive warnings. The default is that -such warnings are not generated. This warning is also turned on by -the use of @option{-gnatwa}. +such warnings are not generated. In addition to the above cases, warnings are also generated for GNAT features that have been provided in past versions but which @@ -5342,7 +5153,6 @@ This switch disables warnings on use of obsolescent features. This switch activates warnings for variables that are initialized but never modified, and then could be declared constants. The default is that such warnings are not given. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwK @emph{Suppress warnings on variables that could be constants.} @@ -5358,11 +5168,9 @@ especially since the names in package Standard continue to be directly visible, meaning that use visibiliy on such redeclared names does not work as expected. Names of discriminants and components in records are not included in this check. -This warning is not part of the warnings activated by @option{-gnatwa}. -It must be explicitly activated. @item -gnatw.K -@emph{Suppress warnings on variables that could be constants.} +@emph{Suppress warnings on redefinition of names in standard.} @cindex @option{-gnatwK} (@command{gcc}) This switch activates warnings for declarations that declare a name that is defined in package Standard. @@ -5371,15 +5179,14 @@ is defined in package Standard. @emph{Activate warnings for elaboration pragmas.} @cindex @option{-gnatwl} (@command{gcc}) @cindex Elaboration, warnings -This switch activates warnings on missing -for possible elaboration problems, including suspicious use +This switch activates warnings for possible elaboration problems, +including suspicious use of @code{Elaborate} pragmas, when using the static elaboration model, and possible situations that may raise @code{Program_Error} when using the dynamic elaboration model. See the section in this guide on elaboration checking for further details. The default is that such warnings are not generated. -This warning is not automatically turned on by the use of @option{-gnatwa}. @item -gnatwL @emph{Suppress warnings for elaboration pragmas.} @@ -5392,7 +5199,6 @@ This switch suppresses warnings for possible elaboration problems. This switch causes the compiler to list inherited invariants, preconditions, and postconditions from Type_Invariant'Class, Invariant'Class, Pre'Class, and Post'Class aspects. Also list inherited subtype predicates. -These messages are not automatically turned on by the use of @option{-gnatwa}. @item -gnatw.L @emph{Suppress listing of inherited aspects.} @@ -5407,7 +5213,6 @@ an initialization value or with one or more assignment statements) but whose value is never read. The warning is suppressed for volatile variables and also for variables that are renamings of other variables or for which an address clause is given. -This warning can also be turned on using @option{-gnatwa}. The default is that these warnings are not given. @item -gnatwM @@ -5449,9 +5254,7 @@ use of @option{-gnatg}. @cindex Atomic Synchronization, warnings This switch actives warnings when an access to an atomic variable requires the generation of atomic synchronization code. These -warnings are off by default and this warning is not included -in @code{-gnatwa}. - +warnings are off by default. @item -gnatw.N @emph{Suppress warnings on atomic synchronization.} @cindex @option{-gnatw.n} (@command{gcc}) @@ -5466,7 +5269,6 @@ requires the generation of atomic synchronization code. This switch activates warnings for possibly unintended initialization effects of defining address clauses that cause one variable to overlap another. The default is that such warnings are generated. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwO @emph{Suppress warnings on address clause overlays.} @@ -5486,8 +5288,7 @@ mode formal, the warning is issued by default (controlled by -gnatwu). The warning is suppressed for volatile variables and also for variables that are renamings of other variables or for which an address clause is given. -The default is that these warnings are not given. Note that this warning -is not included in -gnatwa, it must be activated explicitly. +The default is that these warnings are not given. @item -gnatw.O @emph{Disable warnings on modified but unreferenced out parameters.} @@ -5505,7 +5306,6 @@ This switch activates warnings for failure of front end inlining many reasons for not being able to inline a call, including most commonly that the call is too complex to inline. The default is that such warnings are not given. -This warning can also be turned on using @option{-gnatwa}. Warnings on ineffective inlining by the gcc back-end can be activated separately, using the gcc switch -Winline. @@ -5526,9 +5326,7 @@ match the names of the formals, but are in a different order. The warning is suppressed if any use of named parameter notation is used, so this is the appropriate way to suppress a false positive (and serves to emphasize that the "misordering" is deliberate). The -default is -that such warnings are not given. -This warning can also be turned on using @option{-gnatwa}. +default is that such warnings are not given. @item -gnatw.P @emph{Suppress warnings on parameter ordering.} @@ -5548,7 +5346,6 @@ quite likely ((-x) mod 5) was intended. In such situations it seems best to follow the rule of always parenthesizing to make the association clear, and this warning switch warns if such parentheses are not present. The default is that these warnings are given. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwQ @emph{Suppress warnings on questionable missing parentheses.} @@ -5583,7 +5380,6 @@ to be non-negative Comparison of boolean expressions to an explicit True value. @end itemize -This warning can also be turned on using @option{-gnatwa}. The default is that warnings for redundant constructs are not given. @item -gnatwR @@ -5597,8 +5393,7 @@ This switch suppresses warnings for redundant constructs. This switch activates warnings for an object renaming that renames a function call, which is equivalent to a constant declaration (as opposed to renaming the function itself). The default is that these -warnings are given. This warning can also be turned on using -@option{-gnatwa}. +warnings are given. @item -gnatw.R @emph{Suppress warnings for object renaming function.} @@ -5631,7 +5426,6 @@ specified by an explicit size clause for the component type. A warning is similarly given in the array case if a specified component size overrides an explicit size clause for the array component type. -Note that @option{-gnatwa} does not affect the setting of this warning option. @item -gnatw.S @emph{Suppress warnings on overridden size clauses.} @@ -5647,8 +5441,7 @@ warnings when an array component size overrides a size clause. @cindex Deleted code, warnings This switch activates warnings for tracking of code in conditionals (IF and CASE statements) that is detected to be dead code which cannot be executed, and -which is removed by the front end. This warning is off by default, and is not -turned on by @option{-gnatwa}, it has to be turned on explicitly. This may be +which is removed by the front end. This warning is off by default. This may be useful for detecting deactivated code in certified applications. @item -gnatwT @@ -5667,7 +5460,7 @@ or contract case for this function mentions the result of the function. A procedure postcondition or contract case is suspicious when it only refers to the pre-state of the procedure, because in that case it should rather be expressed as a precondition. The default is that such warnings -are not generated. This warning can also be turned on using @option{-gnatwa}. +are not generated. @item -gnatw.T @emph{Suppress warnings on suspicious contracts.} @@ -5694,7 +5487,6 @@ a warning is also generated, noting that the such warnings are not generated. This switch also activates warnings on unreferenced formals (it includes the effect of @option{-gnatwf}). -This warning can also be turned on using @option{-gnatwa}. @item -gnatwU @emph{Suppress warnings on unused entities.} @@ -5715,7 +5507,6 @@ which the type is declared, or its body or subunits.) Please refer to the description of pragma @code{Ordered} in the @cite{@value{EDITION} Reference Manual} for further details. The default is that such warnings are not generated. -This warning is not automatically turned on by the use of @option{-gnatwa}. @item -gnatw.U @emph{Deactivate warnings on unordered enumeration types.} @@ -5730,7 +5521,6 @@ that no warnings are given for comparisons or subranges for any type. This switch activates warnings for access to variables which may not be properly initialized. The default is that such warnings are generated. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwV @emph{Suppress warnings on unassigned variables.} @@ -5743,7 +5533,7 @@ Table is an array of records whose components are only partially uninitialized, then the following code: @smallexample @c ada - Tab : Table := (others => <>); + Tab : Table := (@b{others} => <>); @end smallexample will suppress warnings on subsequent statements that access components @@ -5758,8 +5548,7 @@ just informational messages) about the effects of non-default bit-order on records to which a component clause is applied. The effect of specifying non-default bit ordering is a bit subtle (and changed with Ada 2005), so these messages, which are given by default, are useful in understanding the -exact consequences of using this feature. These messages -can also be turned on using @option{-gnatwa} +exact consequences of using this feature. @item -gnatw.V @emph{Suppress info messages for non-default bit order.} @@ -5775,7 +5564,6 @@ This switch activates warnings for indexing an unconstrained string parameter with a literal or S'Length. This is a case where the code is assuming that the low bound is one, which is in general not true (for example when a slice is passed). The default is that such warnings are generated. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwW @emph{Suppress warnings on wrong low bound assumption.} @@ -5787,8 +5575,8 @@ assertion that the lower bound is 1, as shown in the following example. @smallexample @c ada - procedure K (S : String) is - pragma Assert (S'First = 1); + @b{procedure} K (S : String) @b{is} + @b{pragma} Assert (S'First = 1); @dots{} @end smallexample @@ -5799,11 +5587,11 @@ as shown in the following example. This switch activates warnings for use of @code{pragma Warnings (Off, entity)} where either the pragma is entirely useless (because it suppresses no warnings), or it could be replaced by @code{pragma Unreferenced} or -@code{pragma Unmodified}. The default is that these warnings are not given. -Note that this warning is not included in -gnatwa, it must be -activated explicitly. Also activates warnings for the case of +@code{pragma Unmodified}. +Also activates warnings for the case of Warnings (Off, String), where either there is no matching Warnings (On, String), or the Warnings (Off) did not suppress any warning. +The default is that these warnings are not given. @item -gnatw.W @emph{Suppress warnings on unnecessary Warnings Off pragmas} @@ -5821,7 +5609,6 @@ default parameters in a convention C procedure is dubious because the C compiler cannot supply the proper default, so a warning is issued. The default is that such warnings are generated. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwX @emph{Suppress warnings on Export/Import pragmas.} @@ -5858,7 +5645,6 @@ switch activates several warnings to help in identifying and correcting such incompatibilities. The default is that these warnings are generated. Note that at one point Ada 2005 was called Ada 0Y, hence the choice of character. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwY @emph{Disable warnings for Ada compatibility issues.} @@ -5896,7 +5682,6 @@ sizes. The default is that such warnings are generated. Warnings are also generated for subprogram pointers with different conventions, and, on VMS only, for data pointers with different conventions. -This warning can also be turned on using @option{-gnatwa}. @item -gnatwZ @emph{Suppress warnings on unchecked conversions.} @@ -5914,7 +5699,6 @@ specified @code{Size} and @code{Alignment} attributes where the size is not a multiple of the alignment, resulting in an object size that is greater than the specified size. The default is that such warnings are generated. -This warning can also be turned on using @option{-gnatwa}. @item -gnatw.Z @emph{Suppress warnings for size not a multiple of alignment.} @@ -5927,17 +5711,17 @@ size that is greater than the specified size. The warning can also be suppressed by giving an explicit @code{Object_Size} value. -@item ^-Wunused^WARNINGS=UNUSED^ +@item -Wunused @cindex @option{-Wunused} The warnings controlled by the @option{-gnatw} switch are generated by the front end of the compiler. The @option{GCC} back end can provide additional warnings and they are controlled by the @option{-W} switch. -For example, @option{^-Wunused^WARNINGS=UNUSED^} activates back end +For example, @option{-Wunused} activates back end warnings for entities that are declared but not referenced. -@item ^-Wuninitialized^WARNINGS=UNINITIALIZED^ +@item -Wuninitialized @cindex @option{-Wuninitialized} -Similarly, @option{^-Wuninitialized^WARNINGS=UNINITIALIZED^} activates +Similarly, @option{-Wuninitialized} activates the back end warning for uninitialized variables. This switch must be used in conjunction with an optimization level greater than zero. @@ -5946,7 +5730,7 @@ used in conjunction with an optimization level greater than zero. Warn if the stack usage of a subprogram might be larger than @var{len} bytes. See @ref{Static Stack Usage Analysis} for details. -@item ^-Wall^/ALL_BACK_END_WARNINGS^ +@item -Wall @cindex @option{-Wall} This switch enables most warnings from the @option{GCC} back end. The code generator detects a number of warning situations that are missed @@ -5954,7 +5738,7 @@ by the @option{GNAT} front end, and this switch can be used to activate them. The use of this switch also sets the default front end warning mode to @option{-gnatwa}, that is, most front end warnings activated as well. -@item ^-w^/NO_BACK_END_WARNINGS^ +@item -w @cindex @option{-w} Conversely, this switch suppresses warnings from the @option{GCC} back end. The use of this switch also sets the default front end warning mode to @@ -5969,7 +5753,6 @@ counted as errors, and prevent the generation of an object file. @end table @noindent -@ifclear vms A string of warning parameters can be used in the same parameter. For example: @smallexample @@ -5979,9 +5762,8 @@ A string of warning parameters can be used in the same parameter. For example: @noindent will turn on all optional warnings except for unrecognized pragma warnings, and also specify that warnings should be treated as errors. -@end ifclear -When no switch @option{^-gnatw^/WARNINGS^} is used, this is equivalent to: +When no switch @option{-gnatw} is used, this is equivalent to: @table @option @c !sort! @@ -6064,27 +5846,6 @@ The @code{Debug} pragma causes @var{procedure} to be called. Note that @code{pragma Debug} may appear within a declaration sequence, allowing debugging procedures to be called between declarations. -@ifset vms -@item /DEBUG@r{[}=debug-level@r{]} -@itemx /NODEBUG -Specifies how much debugging information is to be included in -the resulting object file where 'debug-level' is one of the following: -@table @code -@item TRACEBACK -Include both debugger symbol records and traceback -the object file. -This is the default setting. -@item ALL -Include both debugger symbol records and traceback in -object file. -@item NONE -Excludes both debugger symbol records and traceback -the object file. Same as /NODEBUG. -@item SYMBOLS -Includes only debugger symbol records in the object -file. Note that this doesn't include traceback information. -@end table -@end ifset @end table @node Validity Checking @@ -6118,7 +5879,7 @@ combination with optimization, since this can confuse the optimizer. If performance is a consideration, leading to the need to optimize, then the validity checking options should not be used. -The other @option{-gnatV^@var{x}^^} switches below allow finer-grained +The other @option{-gnatV@var{x}} switches below allow finer-grained control; you can enable whichever validity checks you desire. However, for most debugging purposes, @option{-gnatVa} is sufficient, and the default @option{-gnatVd} (i.e. standard Ada behavior) is usually @@ -6131,18 +5892,11 @@ the compiler can generate more efficient code, since the range of values is better known at compile time. However, an uninitialized variable can cause wild jumps and memory corruption in this mode. -The @option{-gnatV^@var{x}^^} switch allows control over the validity +The @option{-gnatV@var{x}} switch allows control over the validity checking mode as described below. -@ifclear vms The @code{x} argument is a string of letters that indicate validity checks that are performed or not performed in addition to the default checks required by Ada as described above. -@end ifclear -@ifset vms -The options allowed for this qualifier -indicate validity checks that are performed or not performed in addition -to the default checks required by Ada as described above. -@end ifset @table @option @c !sort! @@ -6150,10 +5904,8 @@ to the default checks required by Ada as described above. @emph{All validity checks.} @cindex @option{-gnatVa} (@command{gcc}) All validity checks are turned on. -@ifclear vms That is, @option{-gnatVa} is equivalent to @option{gnatVcdfimorst}. -@end ifclear @item -gnatVc @emph{Validity checks for copies.} @@ -6200,8 +5952,8 @@ as well as out of range values for constrained types. Note that this means that standard IEEE infinity mode is not allowed. The exact contexts in which floating-point values are checked depends on the setting of other options. For example, -@option{^-gnatVif^VALIDITY_CHECKING=(IN_PARAMS,FLOATS)^} or -@option{^-gnatVfi^VALIDITY_CHECKING=(FLOATS,IN_PARAMS)^} +@option{-gnatVif} or +@option{-gnatVfi} (the order does not matter) specifies that floating-point parameters of mode @code{in} should be validity checked. @@ -6277,35 +6029,18 @@ statements are checked, as well as guard expressions in entry calls. @noindent The @option{-gnatV} switch may be followed by -^a string of letters^a list of options^ +a string of letters to turn on a series of validity checking options. For example, -@option{^-gnatVcr^/VALIDITY_CHECKING=(COPIES, RETURNS)^} +@option{-gnatVcr} specifies that in addition to the default validity checking, copies and function return expressions are to be validity checked. In order to make it easier to specify the desired combination of effects, -@ifclear vms the upper case letters @code{CDFIMORST} may be used to turn off the corresponding lower case option. -@end ifclear -@ifset vms -the prefix @code{NO} on an option turns off the corresponding validity -checking: -@itemize @bullet -@item @code{NOCOPIES} -@item @code{NODEFAULT} -@item @code{NOFLOATS} -@item @code{NOIN_PARAMS} -@item @code{NOMOD_PARAMS} -@item @code{NOOPERANDS} -@item @code{NORETURNS} -@item @code{NOSUBSCRIPTS} -@item @code{NOTESTS} -@end itemize -@end ifset Thus -@option{^-gnatVaM^/VALIDITY_CHECKING=(ALL, NOMOD_PARAMS)^} +@option{-gnatVaM} turns on all validity checking options except for checking of @code{@b{in out}} procedure arguments. @@ -6326,7 +6061,7 @@ temporary disabling of validity checks. @findex Style checking @noindent -The @option{-gnaty^x^(option,option,@dots{})^} switch +The @option{-gnatyx} switch @cindex @option{-gnaty} (@command{gcc}) causes the compiler to enforce specified style rules. A limited set of style rules has been used @@ -6350,12 +6085,7 @@ of an existing set of coding rules, you should look to the gnatcheck tool, which is designed for that purpose. @end ifclear -@ifset vms -@code{(option,option,@dots{})} is a sequence of keywords -@end ifset -@ifclear vms The string @var{x} is a sequence of letters or digits -@end ifclear indicating the particular style checks to be performed. The following checks are defined: @@ -6364,7 +6094,7 @@ checks to be performed. The following checks are defined: @item 0-9 @emph{Specify indentation level.} If a digit from 1-9 appears -^in the string after @option{-gnaty}^as an option for /STYLE_CHECKS^ +in the string after @option{-gnaty} then proper indentation is checked, with the digit indicating the indentation level required. A value of zero turns off this style check. The general style of required indentation is as specified by @@ -6375,33 +6105,33 @@ non-blank line (this is useful when full line comments appear in the middle of a statement, or they may be aligned with the source line on the previous non-blank line. -@item ^a^ATTRIBUTE^ +@item a @emph{Check attribute casing.} Attribute names, including the case of keywords such as @code{digits} used as attributes names, must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. All other letters must be lowercase. -@item ^A^ARRAY_INDEXES^ +@item A @emph{Use of array index numbers in array attributes.} When using the array attributes First, Last, Range, or Length, the index number must be omitted for one-dimensional arrays and is required for multi-dimensional arrays. -@item ^b^BLANKS^ +@item b @emph{Blanks not allowed at statement end.} Trailing blanks are not allowed at the end of statements. The purpose of this rule, together with h (no horizontal tabs), is to enforce a canonical format for the use of blanks to separate source tokens. -@item ^B^BOOLEAN_OPERATORS^ +@item B @emph{Check Boolean operators.} The use of AND/OR operators is not permitted except in the cases of modular operands, array operands, and simple stand-alone boolean variables or boolean constants. In all other cases @code{and then}/@code{or else} are required. -@item ^c^COMMENTS^ +@item c @emph{Check comments, double space.} Comments must meet the following set of rules: @@ -6453,28 +6183,28 @@ example: @end smallexample @end itemize -@item ^C^COMMENTS1^ +@item C @emph{Check comments, single space.} -This is identical to @code{^c^COMMENTS^} except that only one space +This is identical to @code{c} except that only one space is required following the @code{--} of a comment instead of two. -@item ^d^DOS_LINE_ENDINGS^ +@item d @emph{Check no DOS line terminators present.} All lines must be terminated by a single ASCII.LF character (in particular the DOS line terminator sequence CR/LF is not allowed). -@item ^e^END^ +@item e @emph{Check end/exit labels.} Optional labels on @code{end} statements ending subprograms and on @code{exit} statements exiting named loops, are required to be present. -@item ^f^VTABS^ +@item f @emph{No form feeds or vertical tabs.} Neither form feeds nor vertical tab characters are permitted in the source text. -@item ^g^GNAT^ +@item g @emph{GNAT style mode.} The set of style check switches is set to match that used by the GNAT sources. This may be useful when developing code that is eventually intended to be @@ -6482,32 +6212,32 @@ incorporated into GNAT. Currently this is equivalent to @option{-gnatwydISux}) but additional style switches may be added to this set in the future without advance notice. -@item ^h^HTABS^ +@item h @emph{No horizontal tabs.} Horizontal tab characters are not permitted in the source text. Together with the b (no blanks at end of line) check, this enforces a canonical form for the use of blanks to separate source tokens. -@item ^i^IF_THEN^ +@item i @emph{Check if-then layout.} The keyword @code{then} must appear either on the same line as corresponding @code{if}, or on a line on its own, lined up under the @code{if}. -@item ^I^IN_MODE^ +@item I @emph{check mode IN keywords.} Mode @code{in} (the default mode) is not allowed to be given explicitly. @code{in out} is fine, but not @code{in} on its own. -@item ^k^KEYWORD^ +@item k @emph{Check keyword casing.} All keywords must be in lower case (with the exception of keywords such as @code{digits} used as attribute names to which this check does not apply). -@item ^l^LAYOUT^ +@item l @emph{Check layout.} Layout of statement and declaration constructs must follow the recommendations in the Ada Reference Manual, as indicated by the @@ -6524,22 +6254,22 @@ For example, any of the following three layouts is acceptable: @smallexample @c ada @cartouche -type q is record +@b{type} q @b{is} @b{record} a : integer; b : integer; -end record; +@b{end} @b{record}; -type q is - record +@b{type} q @b{is} + @b{record} a : integer; b : integer; - end record; + @b{end} @b{record}; -type q is - record +@b{type} q @b{is} + @b{record} a : integer; b : integer; -end record; +@b{end} @b{record}; @end cartouche @end smallexample @@ -6552,18 +6282,18 @@ the block label. For example both the following are permitted: @smallexample @c ada @cartouche -Block : declare +Block : @b{declare} A : Integer := 3; -begin +@b{begin} Proc (A, A); -end Block; +@b{end} Block; Block : - declare + @b{declare} A : Integer := 3; - begin + @b{begin} Proc (A, A); - end Block; + @b{end} Block; @end cartouche @end smallexample @@ -6573,24 +6303,24 @@ the following are permitted: @smallexample @c ada @cartouche -Clear : while J < 10 loop +Clear : @b{while} J < 10 @b{loop} A (J) := 0; -end loop Clear; +@b{end} @b{loop} Clear; Clear : - while J < 10 loop + @b{while} J < 10 @b{loop} A (J) := 0; - end loop Clear; + @b{end} @b{loop} Clear; @end cartouche @end smallexample -@item ^Lnnn^MAX_NESTING=nnn^ +@item Lnnn @emph{Set maximum nesting level.} The maximum level of nesting of constructs (including subprograms, loops, blocks, packages, and conditionals) may not exceed the given value @option{nnn}. A value of zero disconnects this style check. -@item ^m^LINE_LENGTH^ +@item m @emph{Check maximum line length.} The length of source lines must not exceed 79 characters, including any trailing blanks. The value of 79 allows convenient display on an @@ -6600,7 +6330,7 @@ characters in the source text. This means that a tab character counts as one character in this count and a wide character sequence counts as a single character (however many bytes are needed in the encoding). -@item ^Mnnn^MAX_LENGTH=nnn^ +@item Mnnn @emph{Set maximum line length.} The length of lines must not exceed the given value @option{nnn}. The maximum value that can be specified is 32767. @@ -6608,17 +6338,17 @@ If neither style option for setting the line length is used, then the default is 255. This also controls the maximum length of lexical elements, where the only restriction is that they must fit on a single line. -@item ^n^STANDARD_CASING^ +@item n @emph{Check casing of entities in Standard.} Any identifier from Standard must be cased to match the presentation in the Ada Reference Manual (for example, @code{Integer} and @code{ASCII.NUL}). -@item ^N^NONE^ +@item N @emph{Turn off all style checks.} All style check options are turned off. -@item ^o^ORDERED_SUBPROGRAMS^ +@item o @emph{Check order of subprogram bodies.} All subprogram bodies in a given scope (e.g.@: a package body) must be in alphabetical order. The ordering @@ -6627,26 +6357,26 @@ of letters, except that if there is a trailing numeric suffix, then the value of this suffix is used in the ordering (e.g.@: Junk2 comes before Junk10). -@item ^O^OVERRIDING_INDICATORS^ +@item O @emph{Check that overriding subprograms are explicitly marked as such.} The declaration of a primitive operation of a type extension that overrides an inherited operation must carry an overriding indicator. -@item ^p^PRAGMA^ +@item p @emph{Check pragma casing.} Pragma names must be written in mixed case, that is, the initial letter and any letter following an underscore must be uppercase. All other letters must be lowercase. An exception is that SPARK_Mode is allowed as an alternative for Spark_Mode. -@item ^r^REFERENCES^ +@item r @emph{Check references.} All identifier references must be cased in the same way as the corresponding declaration. No specific casing style is imposed on identifiers. The only requirement is for consistency of references with declarations. -@item ^s^SPECS^ +@item s @emph{Check separate specs.} Separate declarations (``specs'') are required for subprograms (a body is not allowed to serve as its own declaration). The only @@ -6654,14 +6384,14 @@ exception is that parameterless library level procedures are not required to have a separate declaration. This exception covers the most frequent form of main program procedures. -@item ^S^STATEMENTS_AFTER_THEN_ELSE^ +@item S @emph{Check no statements after @code{then}/@code{else}.} No statements are allowed on the same line as a @code{then} or @code{else} keyword following the keyword in an @code{if} statement. @code{or else} and @code{and then} are not affected, and a special exception allows a pragma to appear after @code{else}. -@item ^t^TOKEN^ +@item t @emph{Check token spacing.} The following token spacing rules are enforced: @@ -6718,26 +6448,25 @@ A vertical bar must be surrounded by spaces. Exactly one blank (and no other white space) must appear between a @code{not} token and a following @code{in} token. -@item ^u^UNNECESSARY_BLANK_LINES^ +@item u @emph{Check unnecessary blank lines.} Unnecessary blank lines are not allowed. A blank line is considered unnecessary if it appears at the end of the file, or if more than one blank line occurs in sequence. -@item ^x^XTRA_PARENS^ +@item x @emph{Check extra parentheses.} Unnecessary extra level of parentheses (C-style) are not allowed around conditions in @code{if} statements, @code{while} statements and @code{exit} statements. -@item ^y^ALL_BUILTIN^ +@item y @emph{Set all standard style check options} This is equivalent to @code{gnaty3aAbcefhiklmnprst}, that is all checking options enabled with the exception of @option{-gnatyB}, @option{-gnatyd}, @option{-gnatyI}, @option{-gnatyLnnn}, @option{-gnatyo}, @option{-gnatyO}, @option{-gnatyS}, @option{-gnatyu}, and @option{-gnatyx}. -@ifclear vms @item - @emph{Remove style check options} This causes any subsequent options in the string to act as canceling the @@ -6750,17 +6479,9 @@ allowed after @option{-}. @item + This causes any subsequent options in the string to enable the corresponding -style check option. That is, it cancels the effect of a previous ^-^REMOVE^, +style check option. That is, it cancels the effect of a previous -, if any. -@end ifclear -@ifset vms -@item NOxxx -@emph{Removing style check options} -If the name of a style check is preceded by @option{NO} then the corresponding -style check is turned off. For example @option{NOCOMMENTS} turns off style -checking for comments. -@end ifset @end table @noindent @@ -6781,26 +6502,14 @@ file. The @option{-gnatwe} switch can be used to treat warning messages, including style messages, as fatal errors. The switch -@ifclear vms @option{-gnaty} on its own (that is not followed by any letters or digits) is equivalent to the use of @option{-gnatyy} as described above, that is all built-in standard style check options are enabled. -@end ifclear -@ifset vms -/STYLE_CHECKS=ALL_BUILTIN enables all checking options with -the exception of ORDERED_SUBPROGRAMS, UNNECESSARY_BLANK_LINES, -XTRA_PARENS, and DOS_LINE_ENDINGS. In addition -@end ifset The switch -@ifclear vms @option{-gnatyN} -@end ifclear -@ifset vms -/STYLE_CHECKS=NONE -@end ifset clears any previously set style checks. @node Run-Time Checks @@ -6939,7 +6648,7 @@ subscript), or a wild jump (from an out of range case value). Overflow checking is also quite expensive in time and space, since in general it requires the use of double length arithmetic. -Note again that the default is @option{^-gnato00^/OVERFLOW_CHECKS=00^}, +Note again that the default is @option{-gnato00}, so overflow checking is not performed in default mode. This means that out of the box, with the default settings, @value{EDITION} does not do all the checks expected from the language description in the Ada Reference Manual. @@ -6978,11 +6687,9 @@ the program source. @table @option @item -gnats @cindex @option{-gnats} (@command{gcc}) -@ifclear vms @noindent The @code{s} stands for ``syntax''. -@end ifclear Run GNAT in syntax checking only mode. For example, the command @@ -6994,11 +6701,9 @@ $ gcc -c -gnats x.adb @noindent compiles file @file{x.adb} in syntax-check-only mode. You can check a series of files in a single command -@ifclear vms , and can use wild cards to specify such a group of files. Note that you must specify the @option{-c} (compile only) flag in addition to the @option{-gnats} flag. -@end ifclear . You may use other switches in conjunction with @option{-gnats}. In particular, @option{-gnatl} and @option{-gnatv} are useful to control the @@ -7034,10 +6739,8 @@ together. This is primarily used by the @code{gnatchop} utility @item -gnatc @cindex @option{-gnatc} (@command{gcc}) -@ifclear vms @noindent The @code{c} stands for ``check''. -@end ifclear Causes the compiler to operate in semantic check mode, with full checking for all illegalities specified in the Ada Reference Manual, but without generation of any object code @@ -7176,15 +6879,15 @@ extensions, see the GNAT reference manual. @node Character Set Control @subsection Character Set Control @table @option -@item ^-gnati^/IDENTIFIER_CHARACTER_SET=^@var{c} -@cindex @option{^-gnati^/IDENTIFIER_CHARACTER_SET^} (@command{gcc}) +@item -gnati@var{c} +@cindex @option{-gnati} (@command{gcc}) @noindent Normally GNAT recognizes the Latin-1 character set in source program identifiers, as described in the Ada Reference Manual. This switch causes GNAT to recognize alternate character sets in identifiers. @var{c} is a -single character ^^or word^ indicating the character set, as follows: +single character indicating the character set, as follows: @table @code @item 1 @@ -7205,19 +6908,19 @@ ISO 8859-5 (Cyrillic) letters allowed in identifiers @item 9 ISO 8859-15 (Latin-9) letters allowed in identifiers -@item ^p^PC^ +@item p IBM PC letters (code page 437) allowed in identifiers -@item ^8^PC850^ +@item 8 IBM PC letters (code page 850) allowed in identifiers -@item ^f^FULL_UPPER^ +@item f Full upper-half codes allowed in identifiers -@item ^n^NO_UPPER^ +@item n No upper-half codes allowed in identifiers -@item ^w^WIDE^ +@item w Wide-character codes (that is, codes greater than 255) allowed in identifiers @end table @@ -7225,33 +6928,33 @@ allowed in identifiers @xref{Foreign Language Representation}, for full details on the implementation of these character sets. -@item ^-gnatW^/WIDE_CHARACTER_ENCODING=^@var{e} -@cindex @option{^-gnatW^/WIDE_CHARACTER_ENCODING^} (@command{gcc}) +@item -gnatW@var{e} +@cindex @option{-gnatW} (@command{gcc}) Specify the method of encoding for wide characters. @var{e} is one of the following: @table @code -@item ^h^HEX^ +@item h Hex encoding (brackets coding also recognized) -@item ^u^UPPER^ +@item u Upper half encoding (brackets encoding also recognized) -@item ^s^SHIFT_JIS^ +@item s Shift/JIS encoding (brackets encoding also recognized) -@item ^e^EUC^ +@item e EUC encoding (brackets encoding also recognized) -@item ^8^UTF8^ +@item 8 UTF-8 encoding (brackets encoding also recognized) -@item ^b^BRACKETS^ +@item b Brackets encoding only (default value) @end table For full details on these encoding -methods see @ref{Wide Character Encodings}. +methods see @ref{Wide_Character Encodings}. Note that brackets coding is always accepted, even if one of the other options is specified, so for example @option{-gnatW8} specifies that both brackets and UTF-8 encodings will be recognized. The units that are @@ -7303,7 +7006,7 @@ This is a common mode for many programs with foreign language comments. @subsection File Naming Control @table @option -@item ^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{n} +@item -gnatk@var{n} @cindex @option{-gnatk} (@command{gcc}) Activates file name ``krunching''. @var{n}, a decimal integer in the range 1-999, indicates the maximum allowable length of a file name (not @@ -7320,10 +7023,8 @@ For the source file naming rules, @xref{File Naming Rules}. @c !sort! @item -gnatn[12] @cindex @option{-gnatn} (@command{gcc}) -@ifclear vms The @code{n} here is intended to suggest the first syllable of the word ``inline''. -@end ifclear GNAT recognizes and processes @code{Inline} pragmas. However, for the inlining to actually occur, optimization must be enabled and, in order to enable inlining of subprograms specified by pragma @code{Inline}, @@ -7381,7 +7082,6 @@ Print a list of units required by this compilation on @file{stdout}. The listing includes all units on which the unit being compiled depends either directly or indirectly. -@ifclear vms @item -pass-exit-codes @cindex @option{-pass-exit-codes} (@command{gcc}) If this switch is not used, the exit code returned by @command{gcc} when @@ -7402,7 +7102,6 @@ The compiler died unexpectedly (internal error for example). @item 0 An object file has been generated for every source file. @end table -@end ifclear @end table @node Debugging Control @@ -7411,7 +7110,6 @@ An object file has been generated for every source file. @table @option @c !sort! @cindex Debugging options -@ifclear vms @item -gnatd@var{x} @cindex @option{-gnatd} (@command{gcc}) Activate internal debugging switches. @var{x} is a letter or digit, or @@ -7420,7 +7118,6 @@ outputs desired. Normally these are used only for internal development or system debugging purposes. You can find full documentation for these switches in the body of the @code{Debug} unit in the compiler source file @file{debug.adb}. -@end ifclear @item -gnatG[=nn] @cindex @option{-gnatG} (@command{gcc}) @@ -7464,14 +7161,14 @@ Shows the finalization (cleanup) procedure for a scope. @item (if @var{expr} then @var{expr} else @var{expr}) Conditional expression equivalent to the @code{x?y:z} construction in C. -@item @var{target}^^^(@var{source}) +@item @var{target}^(@var{source}) A conversion with floating-point truncation instead of rounding. @item @var{target}?(@var{source}) A conversion that bypasses normal Ada semantic checking. In particular enumeration types and fixed-point types are treated simply as integers. -@item @var{target}?^^^(@var{source}) +@item @var{target}?^(@var{source}) Combines the above two cases. @item @var{x} #/ @var{y} @@ -7532,18 +7229,18 @@ evaluation of the expression 1.0/27.0). When used in conjunction with @option{-gnatG}, this switch causes the expanded source, as described above for @option{-gnatG} to be written to files with names -@file{^xxx.dg^XXX_DG^}, where @file{xxx} is the normal file name, +@file{xxx.dg}, where @file{xxx} is the normal file name, instead of to the standard output file. For example, if the source file name is @file{hello.adb}, then a file -@file{^hello.adb.dg^HELLO.ADB_DG^} will be written. The debugging -information generated by the @command{gcc} @option{^-g^/DEBUG^} switch -will refer to the generated @file{^xxx.dg^XXX_DG^} file. This allows +@file{hello.adb.dg} will be written. The debugging +information generated by the @command{gcc} @option{-g} switch +will refer to the generated @file{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 @option{-gnatx}) since otherwise the cross-reference information -would refer to the @file{^.dg^.DG^} file, which would cause +would refer to the @file{.dg} file, which would cause confusion since this is not the original source file. Note that @option{-gnatD} actually implies @option{-gnatG} @@ -7570,7 +7267,6 @@ or investigated. The switch also causes pragma Profile to be treated as Profile_Warnings, and pragma Restricted_Run_Time and pragma Ravenscar set restriction warnings rather than restrictions. -@ifclear vms @item -gnatR@r{[}0@r{|}1@r{|}2@r{|}3@r{[}s@r{]]} @cindex @option{-gnatR} (@command{gcc}) This switch controls output from the compiler of a listing showing @@ -7592,43 +7288,13 @@ format with #n being used to represent the value of the n'th discriminant. See source files @file{repinfo.ads/adb} in the @code{GNAT} sources for full details on the format of @option{-gnatR3} output. If the switch is followed by an s (e.g.@: @option{-gnatR2s}), then -the output is to a file with the name @file{^file.rep^file_REP^} where +the output is to a file with the name @file{file.rep} where file is the name of the corresponding source file. @item -gnatRm[s] This form of the switch controls output of subprogram conventions and parameter passing mechanisms for all subprograms. A following @code{s} means output to a file as described above. -@end ifclear -@ifset vms -@item /REPRESENTATION_INFO -@cindex @option{/REPRESENTATION_INFO} (@command{gcc}) -This qualifier controls output from the compiler of a listing showing -representation information for declared types and objects. For -@option{/REPRESENTATION_INFO=NONE}, no information is output -(equivalent to omitting the @option{/REPRESENTATION_INFO} qualifier). -@option{/REPRESENTATION_INFO} without option is equivalent to -@option{/REPRESENTATION_INFO=ARRAYS}. -For @option{/REPRESENTATION_INFO=ARRAYS}, size and alignment -information is listed for declared array and record types. For -@option{/REPRESENTATION_INFO=OBJECTS}, size and alignment information -is listed for all expression information for values that are computed -at run time for variant records. These symbolic expressions have a mostly -obvious format with #n being used to represent the value of the n'th -discriminant. See source files @file{REPINFO.ADS/ADB} in the -@code{GNAT} sources for full details on the format of -@option{/REPRESENTATION_INFO=SYMBOLIC} output. -If _FILE is added at the end of an option -(e.g.@: @option{/REPRESENTATION_INFO=ARRAYS_FILE}), -then the output is to a file with the name @file{file_REP} where -file is the name of the corresponding source file. - -@item /REPRESENTATION_INFO=MECHANISMS -This qualifier form controls output of subprogram conventions -and parameter passing mechanisms for all subprograms. It is -possible to append _FILE as described above to cause information -to be written to a file. -@end ifset Note that it is possible for record components to have zero size. In this case, the component clause uses an obvious extension of permitted @@ -7794,13 +7460,13 @@ preprocessing in a file, then you should use @command{gnatprep} to perform the desired preprocessing in stand-alone mode. @noindent -It is recommended that @command{gnatmake} switch ^-s^/SWITCH_CHECK^ should be +It is recommended that @command{gnatmake} switch -s should be used when Integrated Preprocessing is used. The reason is that preprocessing with another Preprocessing Data file without changing the sources will not trigger recompilation without this switch. @noindent -Note that @command{gnatmake} switch ^-m^/MINIMAL_RECOMPILATION^ will almost +Note that @command{gnatmake} switch -m will almost always trigger recompilation for sources that are preprocessed, because @command{gnatmake} cannot compute the checksum of the source after preprocessing. @@ -7842,19 +7508,19 @@ indicating the file name of the definition file to be used for preprocessing 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 -directory as a source directory through switch ^-I.^/SEARCH=[]^, otherwise +directory as a source directory through switch -I., otherwise the compiler would not find the definition file. @noindent -Then, optionally, ^switches^switches^ similar to those of @code{gnatprep} may -be found. Those ^switches^switches^ are: +Then, optionally, switches similar to those of @code{gnatprep} may +be found. Those switches are: @table @code @item -b Causes both preprocessor lines and the lines deleted by preprocessing to be replaced by blank lines, preserving the line number. -This ^switch^switch^ is always implied; however, if specified after @option{-c} +This switch is always implied; however, if specified after @option{-c} it cancels the effect of @option{-c}. @item -c @@ -7867,7 +7533,7 @@ Define or redefine a symbol, associated with value. A symbol is an Ada identifier, or an Ada reserved word, with the exception of @code{if}, @code{else}, @code{elsif}, @code{end}, @code{and}, @code{or} and @code{then}. @code{value} is either a literal string, an Ada identifier or any Ada reserved -word. A symbol declared with this ^switch^switch^ replaces a symbol with the +word. A symbol declared with this switch replaces a symbol with the same name defined in a definition file. @item -s @@ -7899,7 +7565,7 @@ Examples of valid lines in a preprocessor data file: -- list all symbols with their values. @end smallexample -@item ^-gnateD^/DATA_PREPROCESSING=^symbol@r{[}=value@r{]} +@item -gnateDsymbol@r{[}=value@r{]} @cindex @option{-gnateD} (@command{gcc}) Define or redefine a preprocessing symbol, associated with value. If no value is given on the command line, then the value of the symbol is @code{True}. @@ -7910,7 +7576,6 @@ set (letters, digits, period, underline). Ada reserved words may be used as symbols, with the exceptions of @code{if}, @code{else}, @code{elsif}, @code{end}, @code{and}, @code{or} and @code{then}. -@ifclear vms @noindent Examples: @@ -7919,20 +7584,19 @@ Examples: -gnateDFoo -gnateDFoo=\"Foo-Bar\" @end smallexample -@end ifclear @noindent -A symbol declared with this ^switch^switch^ on the command line replaces a +A symbol declared with this switch on the command line replaces a symbol with the same name either in a definition file or specified with a -^switch^switch^ -D in the preprocessor data file. +switch -D in the preprocessor data file. @noindent -This switch is similar to switch @option{^-D^/ASSOCIATE^} of @code{gnatprep}. +This switch is similar to switch @option{-D} of @code{gnatprep}. @item -gnateG When integrated preprocessing is performed and the preprocessor modifies the source text, write the result of this preprocessing into a file -^.prep^_prep^. +.prep. @end table @@ -7965,30 +7629,6 @@ special needs lead to requirements in this area. In particular, there is no point in using @option{-m} switches to improve performance unless you actually see a performance improvement. -@ifset vms -@node Return Codes -@subsection Return Codes -@cindex Return Codes -@cindex @option{/RETURN_CODES=VMS} - -@noindent -On VMS, GNAT compiled programs return POSIX-style codes by default, -e.g.@: @option{/RETURN_CODES=POSIX}. - -To enable VMS style return codes, use GNAT BIND and LINK with the option -@option{/RETURN_CODES=VMS}. For example: - -@smallexample -GNAT BIND MYMAIN.ALI /RETURN_CODES=VMS -GNAT LINK MYMAIN.ALI /RETURN_CODES=VMS -@end smallexample - -@noindent -Programs built with /RETURN_CODES=VMS are suitable to be called in -VMS DCL scripts. Programs compiled with the default /RETURN_CODES=POSIX -are suitable for spawning with appropriate GNAT RTL routines. - -@end ifset @node Search Paths and the Run-Time Library (RTL) @section Search Paths and the Run-Time Library (RTL) @@ -8010,65 +7650,40 @@ The directory containing the source file of the main unit being compiled (the file name on the command line). @item -Each directory named by an @option{^-I^/SOURCE_SEARCH^} switch given on the +Each directory named by an @option{-I} switch given on the @command{gcc} command line, in the order given. @item @findex ADA_PRJ_INCLUDE_FILE Each of the directories listed in the text file whose name is given -by the @env{ADA_PRJ_INCLUDE_FILE} ^environment variable^logical name^. +by the @env{ADA_PRJ_INCLUDE_FILE} environment variable. @noindent -@env{ADA_PRJ_INCLUDE_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ +@env{ADA_PRJ_INCLUDE_FILE} is normally set by gnatmake or by the gnat driver when project files are used. It should not normally be set by other means. @item @findex ADA_INCLUDE_PATH Each of the directories listed in the value of the -@env{ADA_INCLUDE_PATH} ^environment variable^logical name^. -@ifclear vms +@env{ADA_INCLUDE_PATH} environment variable. Construct this value exactly as the @env{PATH} environment variable: a list of directory names separated by colons (semicolons when working with the NT version). -@end ifclear -@ifset vms -Normally, define this value as a logical name containing a comma separated -list of directory names. - -This variable can also be defined by means of an environment string -(an argument to the HP C exec* set of functions). - -Logical Name: -@smallexample -DEFINE ANOTHER_PATH FOO:[BAG] -DEFINE ADA_INCLUDE_PATH ANOTHER_PATH,FOO:[BAM],FOO:[BAR] -@end smallexample - -By default, the path includes GNU:[LIB.OPENVMS7_x.2_8_x.DECLIB] -first, followed by the standard Ada -libraries in GNU:[LIB.OPENVMS7_x.2_8_x.ADAINCLUDE]. -If this is not redefined, the user will obtain the HP Ada 83 IO packages -(Text_IO, Sequential_IO, etc) -instead of the standard Ada packages. Thus, in order to get the standard Ada -packages by default, ADA_INCLUDE_PATH must be redefined. -@end ifset @item The content of the @file{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. -@ifclear vms @ref{Installing a library} -@end ifclear @end enumerate @noindent -Specifying the switch @option{^-I-^/NOCURRENT_DIRECTORY^} +Specifying the switch @option{-I-} inhibits the use of the directory containing the source file named in the command line. You can still have this directory on your search path, but in this case it must be -explicitly requested with a @option{^-I^/SOURCE_SEARCH^} switch. +explicitly requested with a @option{-I} switch. Specifying the switch @option{-nostdinc} inhibits the search of the default location for the GNAT Run Time @@ -8076,12 +7691,10 @@ Library (RTL) source files. The compiler outputs its object files and ALI files in the current working directory. -@ifclear vms Caution: The object file can be redirected with the @option{-o} switch; however, @command{gcc} and @code{gnat1} have not been coordinated on this so the @file{ALI} file will not go to the right place. Therefore, you should avoid using the @option{-o} switch. -@end ifclear @findex System.IO The packages @code{Ada}, @code{System}, and @code{Interfaces} and their @@ -8151,12 +7764,7 @@ The following are some typical Ada compilation command line examples: @item $ gcc -c xyz.adb Compile body in file @file{xyz.adb} with all default options. -@ifclear vms @item $ gcc -c -O2 -gnata xyz-def.adb -@end ifclear -@ifset vms -@item $ GNAT COMPILE /OPTIMIZE=ALL -gnata xyz-def.adb -@end ifset Compile the child unit package in file @file{xyz-def.adb} with extensive optimizations, and pragma @code{Assert}/@code{Debug} statements @@ -8298,7 +7906,7 @@ In most normal usage, the default mode of @command{gnatbind} which is to generate the main package in Ada, as described in the previous section. In particular, this means that any Ada programmer can read and understand the generated main program. It can also be debugged just like any other -Ada code provided the @option{^-g^/DEBUG^} switch is used for +Ada code provided the @option{-g} switch is used for @command{gnatbind} and @command{gnatlink}. @node Switches for gnatbind @@ -8337,28 +7945,28 @@ be treated as an initialisation routine by the linker (a constructor). This is intended to be used by the Project Manager to automatically initialize shared Stand-Alone Libraries. -@item ^-aO^/OBJECT_SEARCH^ -@cindex @option{^-aO^/OBJECT_SEARCH^} (@command{gnatbind}) +@item -aO +@cindex @option{-aO} (@command{gnatbind}) Specify directory to be searched for ALI files. -@item ^-aI^/SOURCE_SEARCH^ -@cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatbind}) +@item -aI +@cindex @option{-aI} (@command{gnatbind}) Specify directory to be searched for source file. -@item ^-A^/ALI_LIST^@r{[=}@var{filename}@r{]} -@cindex @option{^-A^/ALI_LIST^} (@command{gnatbind}) +@item -A@r{[=}@var{filename}@r{]} +@cindex @option{-A} (@command{gnatbind}) Output ALI list (to standard output or to the named file). -@item ^-b^/REPORT_ERRORS=BRIEF^ -@cindex @option{^-b^/REPORT_ERRORS=BRIEF^} (@command{gnatbind}) +@item -b +@cindex @option{-b} (@command{gnatbind}) Generate brief messages to @file{stderr} even if verbose mode set. -@item ^-c^/NOOUTPUT^ -@cindex @option{^-c^/NOOUTPUT^} (@command{gnatbind}) +@item -c +@cindex @option{-c} (@command{gnatbind}) Check only, no generation of binder output file. -@item ^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} -@cindex @option{^-d^/DEFAULT_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]}} (@command{gnatbind}) +@item -d@var{nn}@r{[}k@r{|}m@r{]} +@cindex @option{-d@var{nn}@r{[}k@r{|}m@r{]}} (@command{gnatbind}) This switch can be used to change the default task stack size value to a specified size @var{nn}, which is expressed in bytes by default, or in kilobytes when suffixed with @var{k} or in megabytes when suffixed @@ -8366,12 +7974,12 @@ with @var{m}. In the absence of a @samp{@r{[}k@r{|}m@r{]}} suffix, this switch is equivalent, in effect, to completing all task specs with @smallexample @c ada - pragma Storage_Size (nn); + @b{pragma} Storage_Size (nn); @end smallexample When they do not already have such a pragma. -@item ^-D^/DEFAULT_SECONDARY_STACK_SIZE=^@var{nn}@r{[}k@r{|}m@r{]} -@cindex @option{^-D^/DEFAULT_SECONDARY_STACK_SIZE=nnnnn^} (@command{gnatbind}) +@item -D@var{nn}@r{[}k@r{|}m@r{]} +@cindex @option{-D} (@command{gnatbind}) This switch can be used to change the default secondary stack size value to a specified size @var{nn}, which is expressed in bytes by default, or in kilobytes when suffixed with @var{k} or in megabytes when suffixed @@ -8392,12 +8000,12 @@ 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. -@item ^-e^/ELABORATION_DEPENDENCIES^ -@cindex @option{^-e^/ELABORATION_DEPENDENCIES^} (@command{gnatbind}) +@item -e +@cindex @option{-e} (@command{gnatbind}) Output complete list of elaboration-order dependencies. -@item ^-E^/STORE_TRACEBACKS^ -@cindex @option{^-E^/STORE_TRACEBACKS^} (@command{gnatbind}) +@item -E +@cindex @option{-E} (@command{gnatbind}) Store tracebacks in exception occurrences when the target supports it. @ignore @c The following may get moved to an appendix @@ -8406,13 +8014,11 @@ all x86 ports, Solaris, Windows, HP-UX, AIX, PowerPC VxWorks and Alpha VxWorks. @end ignore See also the packages @code{GNAT.Traceback} and @code{GNAT.Traceback.Symbolic} for more information. -@ifclear vms Note that on x86 ports, you must not use @option{-fomit-frame-pointer} @command{gcc} option. -@end ifclear -@item ^-F^/FORCE_ELABS_FLAGS^ -@cindex @option{^-F^/FORCE_ELABS_FLAGS^} (@command{gnatbind}) +@item -F +@cindex @option{-F} (@command{gnatbind}) Force the checks of elaboration flags. @command{gnatbind} does not normally generate checks of elaboration flags for the main executable, except when a Stand-Alone Library is used. However, there are cases when this cannot be @@ -8421,59 +8027,51 @@ Library through a pragma Import and only specifying through a linker switch this Stand-Alone Library. This switch is used to guarantee that elaboration flag checks are generated. -@item ^-h^/HELP^ -@cindex @option{^-h^/HELP^} (@command{gnatbind}) +@item -h +@cindex @option{-h} (@command{gnatbind}) Output usage (help) information -@item ^-H32^/32_MALLOC^ -@cindex @option{^-H32^/32_MALLOC^} (@command{gnatbind}) +@item -H32 +@cindex @option{-H32} (@command{gnatbind}) Use 32-bit allocations for @code{__gnat_malloc} (and thus for access types). For further details see @ref{Dynamic Allocation Control}. -@item ^-H64^/64_MALLOC^ -@cindex @option{^-H64^/64_MALLOC^} (@command{gnatbind}) +@item -H64 +@cindex @option{-H64} (@command{gnatbind}) Use 64-bit allocations for @code{__gnat_malloc} (and thus for access types). @cindex @code{__gnat_malloc} For further details see @ref{Dynamic Allocation Control}. -@item ^-I^/SEARCH^ -@cindex @option{^-I^/SEARCH^} (@command{gnatbind}) +@item -I +@cindex @option{-I} (@command{gnatbind}) Specify directory to be searched for source and ALI files. -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gnatbind}) +@item -I- +@cindex @option{-I-} (@command{gnatbind}) Do not look for sources in the current directory where @code{gnatbind} was invoked, and do not look for ALI files in the directory containing the ALI file named in the @code{gnatbind} command line. -@item ^-l^/ORDER_OF_ELABORATION^ -@cindex @option{^-l^/ORDER_OF_ELABORATION^} (@command{gnatbind}) +@item -l +@cindex @option{-l} (@command{gnatbind}) Output chosen elaboration order. -@item ^-L@var{xxx}^/BUILD_LIBRARY=@var{xxx}^ -@cindex @option{^-L^/BUILD_LIBRARY^} (@command{gnatbind}) +@item -L@var{xxx} +@cindex @option{-L} (@command{gnatbind}) Bind the units for library building. In this case the adainit and adafinal procedures (@pxref{Binding with Non-Ada Main Programs}) -are renamed to ^@var{xxx}init^@var{XXX}INIT^ and -^@var{xxx}final^@var{XXX}FINAL^. -Implies ^-n^/NOCOMPILE^. -@ifclear vms +are renamed to @var{xxx}init and +@var{xxx}final. +Implies -n. (@xref{GNAT and Libraries}, for more details.) -@end ifclear -@ifset vms -On OpenVMS, these init and final procedures are exported in uppercase -letters. For example if /BUILD_LIBRARY=toto is used, the exported name of -the init procedure will be "TOTOINIT" and the exported name of the final -procedure will be "TOTOFINAL". -@end ifset -@item ^-Mxyz^/RENAME_MAIN=xyz^ -@cindex @option{^-M^/RENAME_MAIN^} (@command{gnatbind}) +@item -Mxyz +@cindex @option{-M} (@command{gnatbind}) Rename generated main program from main to xyz. This option is supported on cross environments only. -@item ^-m^/ERROR_LIMIT=^@var{n} -@cindex @option{^-m^/ERROR_LIMIT^} (@command{gnatbind}) +@item -m@var{n} +@cindex @option{-m} (@command{gnatbind}) Limit number of detected errors or warnings to @var{n}, where @var{n} is in the range 1..999999. The default value if no switch is given is 9999. If the number of warnings reaches this limit, then a @@ -8483,8 +8081,8 @@ limit, then a message is output and the bind is abandoned. A value of zero means that no limit is enforced. The equal sign is optional. -@item ^-n^/NOMAIN^ -@cindex @option{^-n^/NOMAIN^} (@command{gnatbind}) +@item -n +@cindex @option{-n} (@command{gnatbind}) No main program. @item -nostdinc @@ -8500,48 +8098,75 @@ Do not look for library files in the system default directory. Specifies the default location of the runtime library. Same meaning as the equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@item ^-o ^/OUTPUT=^@var{file} -@cindex @option{^-o ^/OUTPUT^} (@command{gnatbind}) +@item -o @var{file} +@cindex @option{-o } (@command{gnatbind}) Name the output file @var{file} (default is @file{b~@var{xxx}.adb}). Note that if this option is used, then linking must be done manually, gnatlink cannot be used. -@item ^-O^/OBJECT_LIST^@r{[=}@var{filename}@r{]} -@cindex @option{^-O^/OBJECT_LIST^} (@command{gnatbind}) +@item -O@r{[=}@var{filename}@r{]} +@cindex @option{-O} (@command{gnatbind}) Output object list (to standard output or to the named file). -@item ^-p^/PESSIMISTIC_ELABORATION^ -@cindex @option{^-p^/PESSIMISTIC_ELABORATION^} (@command{gnatbind}) +@item -p +@cindex @option{-p} (@command{gnatbind}) Pessimistic (worst-case) elaboration order -@item ^-P^-P^ -@cindex @option{^-P^/CODEPEER^} (@command{gnatbind}) +@item -P +@cindex @option{-P} (@command{gnatbind}) Generate binder file suitable for CodePeer. -@item ^-R^-R^ -@cindex @option{^-R^-R^} (@command{gnatbind}) +@item -R +@cindex @option{-R} (@command{gnatbind}) Output closure source list, which includes all non-time-units that are included in the bind. -@item ^-Ra^-Ra^ -@cindex @option{^-Ra^-Ra^} (@command{gnatbind}) +@item -Ra +@cindex @option{-Ra} (@command{gnatbind}) Like @option{-R} but the list includes run-time units. -@item ^-s^/READ_SOURCES=ALL^ -@cindex @option{^-s^/READ_SOURCES=ALL^} (@command{gnatbind}) +@item -s +@cindex @option{-s} (@command{gnatbind}) Require all source files to be present. -@item ^-S@var{xxx}^/INITIALIZE_SCALARS=@var{xxx}^ -@cindex @option{^-S^/INITIALIZE_SCALARS^} (@command{gnatbind}) +@item -S@var{xxx} +@cindex @option{-S} (@command{gnatbind}) Specifies the value to be used when detecting uninitialized scalar objects with pragma Initialize_Scalars. -The @var{xxx} ^string specified with the switch^option^ may be either +The @var{xxx} string specified with the switch is one of: @itemize @bullet -@item ``@option{^in^INVALID^}'' requesting an invalid value where possible -@item ``@option{^lo^LOW^}'' for the lowest possible value -@item ``@option{^hi^HIGH^}'' for the highest possible value -@item ``@option{@var{xx}}'' for a value consisting of repeated bytes with the -value @code{16#@var{xx}#} (i.e., @var{xx} is a string of two hexadecimal digits). + +@item ``@option{in}'' for an invalid value +If zero is invalid for the discrete type in question, +then the scalar value is set to all zero bits. +For signed discrete types, the largest possible negative value of +the underlying scalar is set (i.e. a one bit followed by all zero bits). +For unsigned discrete types, the underlying scalar value is set to all +one bits. For floating-point types, a NaN value is set +(see body of package System.Scalar_Values for exact values). + +@item ``@option{lo}'' for low value +If zero is invalid for the discrete type in question, +then the scalar value is set to all zero bits. +For signed discrete types, the largest possible negative value of +the underlying scalar is set (i.e. a one bit followed by all zero bits). +For unsigned discrete types, the underlying scalar value is set to all +zero bits. For floating-point, a small value is set +(see body of package System.Scalar_Values for exact values). + +@item ``@option{hi}'' for high value +If zero is invalid for the discrete type in question, +then the scalar value is set to all one bits. +For signed discrete types, the largest possible positive value of +the underlying scalar is set (i.e. a zero bit followed by all one bits). +For unsigned discrete types, the underlying scalar value is set to all +one bits. For floating-point, a large value is set +(see body of package System.Scalar_Values for exact values). + +@item ``@option{@var{xx}}'' for hex value (two hex digits) +The underlying scalar is set to a value consisting of repeated bytes, whose +value corresponds to the given value. For example if @option{BF} is given, +then a 32-bit scalar value will be set to the bit patterm 16#BFBFBFBF#. @end itemize In addition, you can specify @option{-Sev} to indicate that the value is @@ -8552,7 +8177,6 @@ of @option{in/lo/hi/@var{xx}} with the same meanings as above. If no environment variable is found, or if it does not have a valid value, then the default is @option{in} (invalid values). -@ifclear vms @item -static @cindex @option{-static} (@code{gnatbind}) Link against a static GNAT run time. @@ -8560,14 +8184,13 @@ Link against a static GNAT run time. @item -shared @cindex @option{-shared} (@code{gnatbind}) Link against a shared GNAT run time when available. -@end ifclear -@item ^-t^/NOTIME_STAMP_CHECK^ -@cindex @option{^-t^/NOTIME_STAMP_CHECK^} (@code{gnatbind}) +@item -t +@cindex @option{-t} (@code{gnatbind}) Tolerate time stamp and other consistency errors -@item ^-T@var{n}^/TIME_SLICE=@var{n}^ -@cindex @option{^-T^/TIME_SLICE^} (@code{gnatbind}) +@item -T@var{n} +@cindex @option{-T} (@code{gnatbind}) Set the time slice value to @var{n} milliseconds. If the system supports the specification of a specific time slice value, then the indicated value is used. If the system does not support specific time slice values, but @@ -8580,78 +8203,50 @@ semantics should match as closely as possible the Annex D requirements of the Ada RM, and in particular sets the default scheduling policy to @code{FIFO_Within_Priorities}. -@item ^-u@var{n}^/DYNAMIC_STACK_USAGE=@var{n}^ -@cindex @option{^-u^/DYNAMIC_STACK_USAGE^} (@code{gnatbind}) +@item -u@var{n} +@cindex @option{-u} (@code{gnatbind}) Enable dynamic stack usage, with @var{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{Dynamic Stack Usage Analysis} for details.) -@item ^-v^/REPORT_ERRORS=VERBOSE^ -@cindex @option{^-v^/REPORT_ERRORS=VERBOSE^} (@code{gnatbind}) +@item -v +@cindex @option{-v} (@code{gnatbind}) Verbose mode. Write error messages, header, summary output to @file{stdout}. -@ifclear vms @item -w@var{x} @cindex @option{-w} (@code{gnatbind}) Warning mode (@var{x}=s/e for suppress/treat as error) -@end ifclear - -@ifset vms -@item /WARNINGS=NORMAL -@cindex @option{/WARNINGS} (@code{gnatbind}) -Normal warnings mode. Warnings are issued but ignored -@item /WARNINGS=SUPPRESS -@cindex @option{/WARNINGS} (@code{gnatbind}) -All warning messages are suppressed -@item /WARNINGS=ERROR -@cindex @option{/WARNINGS} (@code{gnatbind}) -Warning messages are treated as fatal errors -@end ifset - -@item ^-Wx^/WIDE_CHARACTER_ENCODING=^@var{e} -@cindex @option{^-Wx^/WIDE_CHARACTER_ENCODING^} (@code{gnatbind}) +@item -Wx@var{e} +@cindex @option{-Wx} (@code{gnatbind}) Override default wide character encoding for standard Text_IO files. -@item ^-x^/READ_SOURCES=NONE^ -@cindex @option{^-x^/READ_SOURCES^} (@code{gnatbind}) +@item -x +@cindex @option{-x} (@code{gnatbind}) Exclude source files (check object consistency only). -@ifset vms -@item /READ_SOURCES=AVAILABLE -@cindex @option{/READ_SOURCES} (@code{gnatbind}) -Default mode, in which sources are checked for consistency only if -they are available. -@end ifset -@item ^-X@var{nnn}^/RETURN_CODES=POSIX^ -@cindex @option{^-X@var{nnn}^/RETURN_CODES=POSIX^} (@code{gnatbind}) +@item -X@var{nnn} +@cindex @option{-X@var{nnn}} (@code{gnatbind}) Set default exit status value, normally 0 for POSIX compliance. -@ifset vms -@item /RETURN_CODES=VMS -@cindex @option{/RETURN_CODES=VMS} (@code{gnatbind}) -VMS default normal successful return value is 1. -@end ifset -@item ^-y^/ENABLE_LEAP_SECONDS^ -@cindex @option{^-y^/ENABLE_LEAP_SECONDS^} (@code{gnatbind}) +@item -y +@cindex @option{-y} (@code{gnatbind}) Enable leap seconds support in @code{Ada.Calendar} and its children. -@item ^-z^/ZERO_MAIN^ -@cindex @option{^-z^/ZERO_MAIN^} (@code{gnatbind}) +@item -z +@cindex @option{-z} (@code{gnatbind}) No main subprogram. @end table -@ifclear vms @noindent You may obtain this listing of switches by running @code{gnatbind} with no arguments. -@end ifclear @node Consistency-Checking Modes @subsection Consistency-Checking Modes @@ -8664,26 +8259,26 @@ access to sources. @table @option @c !sort! -@item ^-s^/READ_SOURCES=ALL^ -@cindex @option{^-s^/READ_SOURCES=ALL^} (@code{gnatbind}) +@item -s +@cindex @option{-s} (@code{gnatbind}) Require source files to be present. In this mode, the binder must be able to locate all source files that are referenced, in order to check their consistency. In normal mode, if a source file cannot be located it is simply ignored. If you specify this switch, a missing source file is an error. -@item ^-Wx^/WIDE_CHARACTER_ENCODING=^@var{e} -@cindex @option{^-Wx^/WIDE_CHARACTER_ENCODING^} (@code{gnatbind}) +@item -Wx@var{e} +@cindex @option{-Wx} (@code{gnatbind}) Override default wide character encoding for standard Text_IO files. Normally the default wide character encoding method used for standard [Wide_[Wide_]]Text_IO files is taken from the encoding specified for the main source input (see description of switch -@option{^-gnatWx^/WIDE_CHARACTER_ENCODING^} for the compiler). The +@option{-gnatWx} for the compiler). The use of this switch for the binder (which has the same set of possible arguments) overrides this default as specified. -@item ^-x^/READ_SOURCES=NONE^ -@cindex @option{^-x^/READ_SOURCES=NONE^} (@code{gnatbind}) +@item -x +@cindex @option{-x} (@code{gnatbind}) Exclude source files. In this mode, the binder only checks that ALI files are consistent with one another. Source files are not accessed. The binder runs faster in this mode, and there is still a guarantee that @@ -8695,12 +8290,6 @@ mode that is automatically used by @command{gnatmake} because in this case the checking against sources has already been performed by @command{gnatmake} in the course of compilation (i.e.@: before binding). -@ifset vms -@item /READ_SOURCES=AVAILABLE -@cindex @code{/READ_SOURCES=AVAILABLE} (@code{gnatbind}) -This is the default mode in which source files are checked if they are -available, and ignored if they are not available. -@end ifset @end table @node Binder Error Message Control @@ -8712,20 +8301,19 @@ messages from the binder: @table @option @c !sort! -@item ^-v^/REPORT_ERRORS=VERBOSE^ -@cindex @option{^-v^/REPORT_ERRORS=VERBOSE^} (@code{gnatbind}) +@item -v +@cindex @option{-v} (@code{gnatbind}) Verbose mode. In the normal mode, brief error messages are generated to @file{stderr}. If this switch is present, a header is written to @file{stdout} and any error messages are directed to @file{stdout}. All that is written to @file{stderr} is a brief summary message. -@item ^-b^/REPORT_ERRORS=BRIEF^ -@cindex @option{^-b^/REPORT_ERRORS=BRIEF^} (@code{gnatbind}) +@item -b +@cindex @option{-b} (@code{gnatbind}) Generate brief error messages to @file{stderr} even if verbose mode is specified. This is relevant only when used with the -@option{^-v^/REPORT_ERRORS=VERBOSE^} switch. +@option{-v} switch. -@ifclear vms @item -m@var{n} @cindex @option{-m} (@code{gnatbind}) Limits the number of error messages to @var{n}, a decimal integer in the @@ -8737,25 +8325,19 @@ Renames the generated main program from @code{main} to @code{xxx}. This is useful in the case of some cross-building environments, where the actual main program is separate from the one generated by @code{gnatbind}. -@end ifclear -@item ^-ws^/WARNINGS=SUPPRESS^ -@cindex @option{^-ws^/WARNINGS=SUPPRESS^} (@code{gnatbind}) +@item -ws +@cindex @option{-ws} (@code{gnatbind}) @cindex Warnings Suppress all warning messages. -@item ^-we^/WARNINGS=ERROR^ -@cindex @option{^-we^/WARNINGS=ERROR^} (@code{gnatbind}) +@item -we +@cindex @option{-we} (@code{gnatbind}) Treat any warning messages as fatal errors. -@ifset vms -@item /WARNINGS=NORMAL -Standard mode with warnings generated, but warnings do not get treated -as errors. -@end ifset -@item ^-t^/NOTIME_STAMP_CHECK^ -@cindex @option{^-t^/NOTIME_STAMP_CHECK^} (@code{gnatbind}) +@item -t +@cindex @option{-t} (@code{gnatbind}) @cindex Time stamp checks, in binder @cindex Binder consistency checks @cindex Consistency checks, in binder @@ -8778,13 +8360,13 @@ requirements of the Ada Reference Manual, causes error messages to be generated which abort the binder and prevent the output of a binder file and subsequent link to obtain an executable. -The @option{^-t^/NOTIME_STAMP_CHECK^} switch converts these error messages +The @option{-t} switch converts these error messages into warnings, so that binding and linking can continue to completion even in the presence of such errors. The result may be a failed link (due to missing symbols), or a non-functional executable which has undefined semantics. @emph{This means that -@option{^-t^/NOTIME_STAMP_CHECK^} should be used only in unusual situations, +@option{-t} should be used only in unusual situations, with extreme care.} @end table @@ -8796,8 +8378,8 @@ The following switches provide additional control over the elaboration order. For full details see @ref{Elaboration Order Handling in GNAT}. @table @option -@item ^-p^/PESSIMISTIC_ELABORATION^ -@cindex @option{^-p^/PESSIMISTIC_ELABORATION^} (@code{gnatbind}) +@item -p +@cindex @option{-p} (@code{gnatbind}) Normally the binder attempts to choose an elaboration order that is likely to minimize the likelihood of an elaboration order error resulting in raising a @code{Program_Error} exception. This switch reverses the @@ -8806,16 +8388,16 @@ that is likely to maximize the likelihood of an elaboration error. This is useful in ensuring portability and avoiding dependence on accidental fortuitous elaboration ordering. -Normally it only makes sense to use the @option{^-p^/PESSIMISTIC_ELABORATION^} +Normally it only makes sense to use the @option{-p} switch if dynamic elaboration checking is used (@option{-gnatE} switch used for compilation). This is because in the default static elaboration mode, all necessary @code{Elaborate} and @code{Elaborate_All} pragmas are implicitly inserted. These implicit pragmas are still respected by the binder in -@option{^-p^/PESSIMISTIC_ELABORATION^} mode, so a +@option{-p} mode, so a safe elaboration order is assured. -Note that @option{^-p^/PESSIMISTIC_ELABORATION^} is not intended for +Note that @option{-p} is not intended for production use; it is more for debugging/experimental use. @end table @@ -8829,34 +8411,34 @@ generated by the binder. @table @option @c !sort! -@item ^-c^/NOOUTPUT^ -@cindex @option{^-c^/NOOUTPUT^} (@code{gnatbind}) +@item -c +@cindex @option{-c} (@code{gnatbind}) Check only. Do not generate the binder output file. In this mode the binder performs all error checks but does not generate an output file. -@item ^-e^/ELABORATION_DEPENDENCIES^ -@cindex @option{^-e^/ELABORATION_DEPENDENCIES^} (@code{gnatbind}) +@item -e +@cindex @option{-e} (@code{gnatbind}) Output complete list of elaboration-order dependencies, showing the reason for each dependency. This output can be rather extensive but may be useful in diagnosing problems with elaboration order. The output is written to @file{stdout}. -@item ^-h^/HELP^ -@cindex @option{^-h^/HELP^} (@code{gnatbind}) +@item -h +@cindex @option{-h} (@code{gnatbind}) Output usage information. The output is written to @file{stdout}. -@item ^-K^/LINKER_OPTION_LIST^ -@cindex @option{^-K^/LINKER_OPTION_LIST^} (@code{gnatbind}) +@item -K +@cindex @option{-K} (@code{gnatbind}) Output linker options to @file{stdout}. Includes library search paths, contents of pragmas Ident and Linker_Options, and libraries added by @code{gnatbind}. -@item ^-l^/ORDER_OF_ELABORATION^ -@cindex @option{^-l^/ORDER_OF_ELABORATION^} (@code{gnatbind}) +@item -l +@cindex @option{-l} (@code{gnatbind}) Output chosen elaboration order. The output is written to @file{stdout}. -@item ^-O^/OBJECT_LIST^ -@cindex @option{^-O^/OBJECT_LIST^} (@code{gnatbind}) +@item -O +@cindex @option{-O} (@code{gnatbind}) Output full names of all the object files that must be linked to provide the Ada component of the program. The output is written to @file{stdout}. This list includes the files explicitly supplied and referenced by the user @@ -8864,8 +8446,8 @@ as well as implicitly referenced run-time unit files. The latter are omitted if the corresponding units reside in shared libraries. The directory names for the run-time units depend on the system configuration. -@item ^-o ^/OUTPUT=^@var{file} -@cindex @option{^-o^/OUTPUT^} (@code{gnatbind}) +@item -o @var{file} +@cindex @option{-o} (@code{gnatbind}) Set name of output file to @var{file} instead of the normal @file{b~@var{mainprog}.adb} default. Note that @var{file} denote the Ada binder generated body filename. @@ -8873,8 +8455,8 @@ Note that if this option is used, then linking must be done manually. It is not possible to use gnatlink in this case, since it cannot locate the binder file. -@item ^-r^/RESTRICTION_LIST^ -@cindex @option{^-r^/RESTRICTION_LIST^} (@code{gnatbind}) +@item -r +@cindex @option{-r} (@code{gnatbind}) Generate list of @code{pragma Restrictions} that could be applied to the current unit. This is useful for code audit purposes, and also may be used to improve code generation in some cases. @@ -8900,14 +8482,8 @@ Allocate memory on 64-bit heap. This is the default unless explicitly overridden by a @code{'Size} clause on the access type. @end table -@ifset vms -@noindent -See also @ref{Access types and 32/64-bit allocation}. -@end ifset -@ifclear vms @noindent These switches are only effective on VMS platforms. -@end ifclear @node Binding with Non-Ada Main Programs @@ -8923,8 +8499,8 @@ written in Ada and compiled using GNAT (@pxref{Mixed Language Programming}). The following switch is used in this situation: @table @option -@item ^-n^/NOMAIN^ -@cindex @option{^-n^/NOMAIN^} (@code{gnatbind}) +@item -n +@cindex @option{-n} (@code{gnatbind}) No main program. The main program is not in Ada. @end table @@ -8957,8 +8533,8 @@ terminates. @end table @noindent -If the @option{^-n^/NOMAIN^} switch -@cindex @option{^-n^/NOMAIN^} (@command{gnatbind}) +If the @option{-n} switch +@cindex @option{-n} (@command{gnatbind}) @cindex Binder, multiple input files is given, more than one ALI file may appear on the command line for @code{gnatbind}. The normal @dfn{closure} @@ -8969,8 +8545,8 @@ specify more than one ALI file is that a given program may invoke two or more quite separate groups of Ada units. The binder takes the name of its output file from the last specified ALI -file, unless overridden by the use of the @option{^-o file^/OUTPUT=file^}. -@cindex @option{^-o^/OUTPUT^} (@command{gnatbind}) +file, unless overridden by the use of the @option{-o file}. +@cindex @option{-o} (@command{gnatbind}) The output is an Ada unit in source form that can be compiled with GNAT. This compilation occurs automatically as part of the @command{gnatlink} processing. @@ -8993,8 +8569,8 @@ packages, then the finalization routines. The following switch is used to bind programs organized in this manner: @table @option -@item ^-z^/ZERO_MAIN^ -@cindex @option{^-z^/ZERO_MAIN^} (@code{gnatbind}) +@item -z +@cindex @option{-z} (@code{gnatbind}) Normally the binder checks that the unit name given on the command line corresponds to a suitable main subprogram. When this switch is used, a list of ALI files can be given, and the execution of the program @@ -9002,7 +8578,7 @@ consists of elaboration of these units in an appropriate order. Note that the default wide character encoding method for standard Text_IO files is always set to Brackets if this switch is set (you can use the binder switch -@option{^-Wx^WIDE_CHARACTER_ENCODING^} to override this default). +@option{-Wx} to override this default). @end table @node Command-Line Access @@ -9025,9 +8601,9 @@ char **gnat_argv; @findex gnat_argc are declared in one of the GNAT library routines. These variables must be set from the actual @code{argc} and @code{argv} values passed to the -main program. With no @option{^n^/NOMAIN^} present, @code{gnatbind} +main program. With no @option{n} present, @code{gnatbind} generates the C main program to automatically set these variables. -If the @option{^n^/NOMAIN^} switch is used, there is no automatic way to +If the @option{n} switch is used, there is no automatic way to set these variables. If they are not set, the procedures in @code{Ada.Command_Line} will not be available, and any attempt to use them will raise @code{Constraint_Error}. If command line access is @@ -9049,79 +8625,54 @@ directories searched are: @enumerate @item The directory containing the ALI file named in the command line, unless -the switch @option{^-I-^/NOCURRENT_DIRECTORY^} is specified. +the switch @option{-I-} is specified. @item -All directories specified by @option{^-I^/SEARCH^} +All directories specified by @option{-I} switches on the @code{gnatbind} command line, in the order given. @item @findex ADA_PRJ_OBJECTS_FILE Each of the directories listed in the text file whose name is given -by the @env{ADA_PRJ_OBJECTS_FILE} ^environment variable^logical name^. +by the @env{ADA_PRJ_OBJECTS_FILE} environment variable. @noindent -@env{ADA_PRJ_OBJECTS_FILE} is normally set by gnatmake or by the ^gnat^GNAT^ +@env{ADA_PRJ_OBJECTS_FILE} is normally set by gnatmake or by the gnat driver when project files are used. It should not normally be set by other means. @item @findex ADA_OBJECTS_PATH Each of the directories listed in the value of the -@env{ADA_OBJECTS_PATH} ^environment variable^logical name^. -@ifset unw +@env{ADA_OBJECTS_PATH} environment variable. Construct this value exactly as the @env{PATH} environment variable: a list of directory names separated by colons (semicolons when working with the NT version of GNAT). -@end ifset -@ifset vms -Normally, define this value as a logical name containing a comma separated -list of directory names. - -This variable can also be defined by means of an environment string -(an argument to the HP C exec* set of functions). - -Logical Name: -@smallexample -DEFINE ANOTHER_PATH FOO:[BAG] -DEFINE ADA_OBJECTS_PATH ANOTHER_PATH,FOO:[BAM],FOO:[BAR] -@end smallexample - -By default, the path includes GNU:[LIB.OPENVMS7_x.2_8_x.DECLIB] -first, followed by the standard Ada -libraries in GNU:[LIB.OPENVMS7_x.2_8_x.ADALIB]. -If this is not redefined, the user will obtain the HP Ada 83 IO packages -(Text_IO, Sequential_IO, etc) -instead of the standard Ada packages. Thus, in order to get the standard Ada -packages by default, ADA_OBJECTS_PATH must be redefined. -@end ifset @item The content of the @file{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 @option{-nostdlib} is specified. -@ifclear vms @ref{Installing a library} -@end ifclear @end enumerate @noindent -In the binder the switch @option{^-I^/SEARCH^} -@cindex @option{^-I^/SEARCH^} (@command{gnatbind}) +In the binder the switch @option{-I} +@cindex @option{-I} (@command{gnatbind}) is used to specify both source and -library file paths. Use @option{^-aI^/SOURCE_SEARCH^} -@cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatbind}) +library file paths. Use @option{-aI} +@cindex @option{-aI} (@command{gnatbind}) instead if you want to specify -source paths only, and @option{^-aO^/LIBRARY_SEARCH^} -@cindex @option{^-aO^/LIBRARY_SEARCH^} (@command{gnatbind}) +source paths only, and @option{-aO} +@cindex @option{-aO} (@command{gnatbind}) if you want to specify library paths only. This means that for the binder -@option{^-I^/SEARCH=^}@var{dir} is equivalent to -@option{^-aI^/SOURCE_SEARCH=^}@var{dir} -@option{^-aO^/OBJECT_SEARCH=^}@var{dir}. +@option{-I}@var{dir} is equivalent to +@option{-aI}@var{dir} +@option{-aO}@var{dir}. The binder generates the bind file (a C language source file) in the current working directory. @@ -9158,12 +8709,7 @@ The main program @code{Hello} (source program in @file{hello.adb}) is bound using the standard switch settings. The generated main program is @file{b~hello.adb}. This is the normal, default use of the binder. -@ifclear vms @item gnatbind hello -o mainprog.adb -@end ifclear -@ifset vms -@item gnatbind HELLO.ALI /OUTPUT=Mainprog.ADB -@end ifset The main program @code{Hello} (source program in @file{hello.adb}) is bound using the standard switch settings. The generated main program is @file{mainprog.adb} with the associated spec in @@ -9181,7 +8727,7 @@ since gnatlink will not be able to find the generated file. @noindent This chapter discusses @command{gnatlink}, a tool that links an Ada program and builds an executable file. This utility -invokes the system linker ^(via the @command{gcc} command)^^ +invokes the system linker (via the @command{gcc} command) with a correct list of object files and library references. @command{gnatlink} automatically determines the list of files and references for the Ada part of a program. It uses the binder file @@ -9255,15 +8801,13 @@ details. Here is an example showing how to generate a linker map: @smallexample -$ ^gnatlink my_prog -Wl,-Map,MAPFILE^GNAT LINK my_prog.ali /MAP^ +$ gnatlink my_prog -Wl,-Map,MAPFILE @end smallexample Using @var{linker options} it is possible to set the program stack and heap size. -@ifset unw See @ref{Setting Stack Size from gnatlink} and @ref{Setting Heap Size from gnatlink}. -@end ifset @command{gnatlink} determines the list of objects required by the Ada program and prepends them to the list of objects passed to the linker. @@ -9271,12 +8815,6 @@ program and prepends them to the list of objects passed to the linker. @code{pragma Linker_Options} and adds them to the list of arguments presented to the linker. -@ifset vms -@command{gnatlink} accepts the following types of extra files on the command -line: objects (@file{.OBJ}), libraries (@file{.OLB}), sharable images -(@file{.EXE}), and options files (@file{.OPT}). These are recognized and -handled according to their extension. -@end ifset @node Switches for gnatlink @section Switches for @command{gnatlink} @@ -9296,55 +8834,54 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-f^/FORCE_OBJECT_FILE_LIST^ +@item -f @cindex Command line length -@cindex @option{^-f^/FORCE_OBJECT_FILE_LIST^} (@command{gnatlink}) +@cindex @option{-f} (@command{gnatlink}) On some targets, the command line length is limited, and @command{gnatlink} will generate a separate file for the linker if the list of object files is too long. -The @option{^-f^/FORCE_OBJECT_FILE_LIST^} switch forces this file +The @option{-f} switch forces this file to be generated even if the limit is not exceeded. This is useful in some cases to deal with special situations where the command line length is exceeded. -@item ^-g^/DEBUG^ +@item -g @cindex Debugging information, including -@cindex @option{^-g^/DEBUG^} (@command{gnatlink}) +@cindex @option{-g} (@command{gnatlink}) The option to include debugging information causes the Ada bind file (in other words, @file{b~@var{mainprog}.adb}) to be compiled with -@option{^-g^/DEBUG^}. +@option{-g}. In addition, the binder does not delete the @file{b~@var{mainprog}.adb}, @file{b~@var{mainprog}.o} and @file{b~@var{mainprog}.ali} files. -Without @option{^-g^/DEBUG^}, the binder removes these files by +Without @option{-g}, the binder removes these files by default. The same procedure apply if a C bind file was generated using -@option{^-C^/BIND_FILE=C^} @code{gnatbind} option, in this case the filenames +@option{-C} @code{gnatbind} option, in this case the filenames are @file{b_@var{mainprog}.c} and @file{b_@var{mainprog}.o}. -@item ^-n^/NOCOMPILE^ -@cindex @option{^-n^/NOCOMPILE^} (@command{gnatlink}) +@item -n +@cindex @option{-n} (@command{gnatlink}) Do not compile the file generated by the binder. This may be used when a link is rerun with different options, but there is no need to recompile the binder file. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@command{gnatlink}) +@item -v +@cindex @option{-v} (@command{gnatlink}) Causes additional information to be output, including a full list of the included object files. This switch option is most useful when you want to see what set of object files are being used in the link step. -@item ^-v -v^/VERBOSE/VERBOSE^ -@cindex @option{^-v -v^/VERBOSE/VERBOSE^} (@command{gnatlink}) +@item -v -v +@cindex @option{-v -v} (@command{gnatlink}) Very verbose mode. Requests that the compiler operate in verbose mode when it compiles the binder file, and that the system linker run in verbose mode. -@item ^-o ^/EXECUTABLE=^@var{exec-name} -@cindex @option{^-o^/EXECUTABLE^} (@command{gnatlink}) +@item -o @var{exec-name} +@cindex @option{-o} (@command{gnatlink}) @var{exec-name} specifies an alternate name for the generated executable program. If this switch is omitted, the executable has the same name as the main unit. For example, @code{gnatlink try.ali} creates -an executable called @file{^try^TRY.EXE^}. +an executable called @file{try}. -@ifclear vms @item -b @var{target} @cindex @option{-b} (@command{gnatlink}) Compile your program to run on @var{target}, which is the name of a @@ -9402,32 +8939,7 @@ script that massages the parameters before invoking the real linker. It may be useful to control the exact invocation by using the verbose switch. -@end ifclear -@ifset vms -@item /DEBUG=TRACEBACK -@cindex @code{/DEBUG=TRACEBACK} (@command{gnatlink}) -This qualifier causes sufficient information to be included in the -executable file to allow a traceback, but does not include the full -symbol information needed by the debugger. - -@item /IDENTIFICATION="" -@code{""} specifies the string to be stored in the image file -identification field in the image header. -It overrides any pragma @code{Ident} specified string. - -@item /NOINHIBIT-EXEC -Generate the executable file even if there are linker warnings. - -@item /NOSTART_FILES -Don't link in the object file containing the ``main'' transfer address. -Used when linking with a foreign language main program compiled with an -HP compiler. - -@item /STATIC -Prefer linking with object libraries over sharable images, even without -/DEBUG. -@end ifset @end table @@ -9518,9 +9030,9 @@ the source path of the compiler as described in @ref{Search Paths and the Run-Time Library (RTL)}. All @command{gnatmake} output (except when you specify -@option{^-M^/DEPENDENCIES_LIST^}) is to +@option{-M}) is to @file{stderr}. The output produced by the -@option{^-M^/DEPENDENCIES_LIST^} switch is send to +@option{-M} switch is send to @file{stdout}. @node Switches for gnatmake @@ -9541,7 +9053,6 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@ifclear vms @item --GCC=@var{compiler_name} @cindex @option{--GCC=compiler_name} (@command{gnatmake}) Program used for compiling. The default is `@command{gcc}'. You need to use @@ -9580,22 +9091,21 @@ linker. Linker switches that are normally appended by @command{gnatmake} to A limitation of this syntax is that the name and path name of the executable itself must not include any embedded spaces. -@end ifclear -@item ^--subdirs^/SUBDIRS^=subdir +@item --subdirs=subdir Actual object directory of each project file is the subdirectory subdir of the object directory specified or defaulted in the project file. -@item ^--single-compile-per-obj-dir^/SINGLE_COMPILE_PER_OBJ_DIR^ +@item --single-compile-per-obj-dir Disallow simultaneous compilations in the same object directory when project files are used. -@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +@item --unchecked-shared-lib-imports By default, shared library projects are not allowed to import static library projects. When this switch is used on the command line, this restriction is relaxed. -@item ^--source-info=^/SRC_INFO=source-info-file^ +@item --source-info= Specify a source info file. This switch is active only when project files are used. If the source info file is specified as a relative path, then it is relative to the object directory of the main project. If the source info file @@ -9612,7 +9122,6 @@ fail. @command{gnatmake} "trusts" the source info file. This means that if the source files have changed (addition, deletion, moving to a different source directory), then the source info file need to be deleted and recreated. -@ifclear vms @item --create-map-file When linking an executable, create a map file. The name of the map file has the same name as the executable with extension ".map". @@ -9621,10 +9130,9 @@ has the same name as the executable with extension ".map". When linking an executable, create a map file. The name of the map file is "mapfile". -@end ifclear -@item ^-a^/ALL_FILES^ -@cindex @option{^-a^/ALL_FILES^} (@command{gnatmake}) +@item -a +@cindex @option{-a} (@command{gnatmake}) Consider all files in the make process, even the GNAT internal system files (for example, the predefined Ada library files), as well as any locked files. Locked files are files whose ALI file is write-protected. @@ -9636,72 +9144,67 @@ installed. Note that if there is an installation problem, such that one of these files is not up to date, it will be properly caught by the binder. You may have to specify this switch if you are working on GNAT -itself. The switch @option{^-a^/ALL_FILES^} is also useful -in conjunction with @option{^-f^/FORCE_COMPILE^} +itself. The switch @option{-a} is also useful +in conjunction with @option{-f} if you need to recompile an entire application, including run-time files, using special configuration pragmas, such as a @code{Normalize_Scalars} pragma. By default -@code{gnatmake ^-a^/ALL_FILES^} compiles all GNAT +@code{gnatmake -a} compiles all GNAT internal files with -@ifclear vms @code{gcc -c -gnatpg} rather than @code{gcc -c}. -@end ifclear -@ifset vms -the @code{/CHECKS=SUPPRESS_ALL /STYLE_CHECKS=GNAT} switch. -@end ifset -@item ^-b^/ACTIONS=BIND^ -@cindex @option{^-b^/ACTIONS=BIND^} (@command{gnatmake}) -Bind only. Can be combined with @option{^-c^/ACTIONS=COMPILE^} to do +@item -b +@cindex @option{-b} (@command{gnatmake}) +Bind only. Can be combined with @option{-c} to do compilation and binding, but no link. -Can be combined with @option{^-l^/ACTIONS=LINK^} +Can be combined with @option{-l} to do binding and linking. When not combined with -@option{^-c^/ACTIONS=COMPILE^} +@option{-c} all the units in the closure of the main program must have been previously compiled and must be up to date. The root unit specified by @var{file_name} may be given without extension, with the source extension or, if no GNAT Project File is specified, with the ALI file extension. -@item ^-c^/ACTIONS=COMPILE^ -@cindex @option{^-c^/ACTIONS=COMPILE^} (@command{gnatmake}) -Compile only. Do not perform binding, except when @option{^-b^/ACTIONS=BIND^} +@item -c +@cindex @option{-c} (@command{gnatmake}) +Compile only. Do not perform binding, except when @option{-b} is also specified. Do not perform linking, except if both -@option{^-b^/ACTIONS=BIND^} and -@option{^-l^/ACTIONS=LINK^} are also specified. +@option{-b} and +@option{-l} are also specified. If the root unit specified by @var{file_name} is not a main unit, this is the default. Otherwise @command{gnatmake} will attempt binding and linking unless all objects are up to date and the executable is more recent than the objects. -@item ^-C^/MAPPING^ -@cindex @option{^-C^/MAPPING^} (@command{gnatmake}) +@item -C +@cindex @option{-C} (@command{gnatmake}) Use a temporary mapping file. A mapping file is a way to communicate to the compiler two mappings: from unit names to file names (without any directory information) and from file names to path names (with full directory information). A mapping file can make the compiler's file searches faster, especially if there are many source directories, or the sources are read over a slow network connection. If -@option{^-P^/PROJECT_FILE^} is used, a mapping file is always used, so -@option{^-C^/MAPPING^} is unnecessary; in this case the mapping file +@option{-P} is used, a mapping file is always used, so +@option{-C} is unnecessary; in this case the mapping file is initially populated based on the project file. If -@option{^-C^/MAPPING^} is used without -@option{^-P^/PROJECT_FILE^}, +@option{-C} is used without +@option{-P}, the mapping file is initially empty. Each invocation of the compiler will add any newly accessed sources to the mapping file. -@item ^-C=^/USE_MAPPING_FILE=^@var{file} -@cindex @option{^-C=^/USE_MAPPING^} (@command{gnatmake}) +@item -C=@var{file} +@cindex @option{-C=} (@command{gnatmake}) Use a specific mapping file. The file, specified as a path name (absolute or relative) by this switch, should already exist, otherwise the switch is ineffective. The specified mapping file will be communicated to the compiler. This switch is not compatible with a project file -(^-P^/PROJECT_FILE=^@var{file}) or with multiple compiling processes -(^-j^/PROCESSES=^nnn, when nnn is greater than 1). +(-P@var{file}) or with multiple compiling processes +(-jnnn, when nnn is greater than 1). -@item ^-d^/DISPLAY_PROGRESS^ -@cindex @option{^-d^/DISPLAY_PROGRESS^} (@command{gnatmake}) +@item -d +@cindex @option{-d} (@command{gnatmake}) Display progress for each source, up to date or not, as a single line @smallexample @@ -9711,10 +9214,10 @@ completed x out of y (zz%) If the file needs to be compiled this is displayed after the invocation of the compiler. These lines are displayed even in quiet output mode. -@item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} -@cindex @option{^-D^/DIRECTORY_OBJECTS^} (@command{gnatmake}) +@item -D @var{dir} +@cindex @option{-D} (@command{gnatmake}) Put all object files and ALI file in directory @var{dir}. -If the @option{^-D^/DIRECTORY_OBJECTS^} switch is not used, all object files +If the @option{-D} switch is not used, all object files and ALI files go in the current working directory. This switch cannot be used when using a project file. @@ -9726,7 +9229,6 @@ in the source file is nnn. nnn needs to be a positive number and a valid index in the source. This switch cannot be used when @command{gnatmake} is invoked for several mains. -@ifclear vms @item -eL @cindex @option{-eL} (@command{gnatmake}) @cindex symbolic links @@ -9744,37 +9246,36 @@ save a lot of system calls (several per source file and object file), which can result in a significant speed up to load and manipulate a project file, especially when using source files from a remote system. -@end ifclear -@item ^-eS^/STANDARD_OUTPUT_FOR_COMMANDS^ -@cindex @option{^-eS^/STANDARD_OUTPUT_FOR_COMMANDS^} (@command{gnatmake}) +@item -eS +@cindex @option{-eS} (@command{gnatmake}) Output the commands for the compiler, the binder and the linker -on ^standard output^SYS$OUTPUT^, -instead of ^standard error^SYS$ERROR^. +on standard output, +instead of standard error. -@item ^-f^/FORCE_COMPILE^ -@cindex @option{^-f^/FORCE_COMPILE^} (@command{gnatmake}) +@item -f +@cindex @option{-f} (@command{gnatmake}) Force recompilations. Recompile all sources, even though some object files may be up to date, but don't recompile predefined or GNAT internal files or locked files (files with a write-protected ALI file), -unless the @option{^-a^/ALL_FILES^} switch is also specified. +unless the @option{-a} switch is also specified. -@item ^-F^/FULL_PATH_IN_BRIEF_MESSAGES^ -@cindex @option{^-F^/FULL_PATH_IN_BRIEF_MESSAGES^} (@command{gnatmake}) +@item -F +@cindex @option{-F} (@command{gnatmake}) When using project files, if some errors or warnings are detected during parsing and verbose mode is not in effect (no use of switch -^-v^/VERBOSE^), then error lines start with the full path name of the project +-v), then error lines start with the full path name of the project file, rather than its simple file name. -@item ^-g^/DEBUG^ -@cindex @option{^-g^/DEBUG^} (@command{gnatmake}) +@item -g +@cindex @option{-g} (@command{gnatmake}) Enable debugging. This switch is simply passed to the compiler and to the linker. -@item ^-i^/IN_PLACE^ -@cindex @option{^-i^/IN_PLACE^} (@command{gnatmake}) +@item -i +@cindex @option{-i} (@command{gnatmake}) In normal mode, @command{gnatmake} compiles all object files and ALI files -into the current directory. If the @option{^-i^/IN_PLACE^} switch is used, +into the current directory. If the @option{-i} switch is used, 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 @command{gnatmake} will automatically @@ -9788,8 +9289,8 @@ When detecting such a dummy file, @command{gnatmake} will be forced to recompile the corresponding source file, and it will be put the resulting object and ALI files in the directory where it found the dummy file. -@item ^-j^/PROCESSES=^@var{n} -@cindex @option{^-j^/PROCESSES^} (@command{gnatmake}) +@item -j@var{n} +@cindex @option{-j} (@command{gnatmake}) @cindex Parallel make Use @var{n} processes to carry out the (re)compilations. On a multiprocessor machine compilations will occur in parallel. If @var{n} is 0, then the @@ -9799,8 +9300,8 @@ compilations might get interspersed (but @command{gnatmake} will give you the full ordered list of failing compiles at the end). If this is problematic, rerun the make process with n set to 1 to get a clean list of messages. -@item ^-k^/CONTINUE_ON_ERROR^ -@cindex @option{^-k^/CONTINUE_ON_ERROR^} (@command{gnatmake}) +@item -k +@cindex @option{-k} (@command{gnatmake}) Keep going. Continue as much as possible after a compilation error. To ease the programmer's task in case of compilation errors, the list of sources for which the compile fails is given when @command{gnatmake} @@ -9810,21 +9311,21 @@ If @command{gnatmake} is invoked with several @file{file_names} and with this switch, if there are compilation errors when building an executable, @command{gnatmake} will not attempt to build the following executables. -@item ^-l^/ACTIONS=LINK^ -@cindex @option{^-l^/ACTIONS=LINK^} (@command{gnatmake}) -Link only. Can be combined with @option{^-b^/ACTIONS=BIND^} to binding +@item -l +@cindex @option{-l} (@command{gnatmake}) +Link only. Can be combined with @option{-b} to binding and linking. Linking will not be performed if combined with -@option{^-c^/ACTIONS=COMPILE^} -but not with @option{^-b^/ACTIONS=BIND^}. -When not combined with @option{^-b^/ACTIONS=BIND^} +@option{-c} +but not with @option{-b}. +When not combined with @option{-b} all the units in the closure of the main program must have been previously compiled and must be up to date, and the main program needs to have been bound. The root unit specified by @var{file_name} may be given without extension, with the source extension or, if no GNAT Project File is specified, with the ALI file extension. -@item ^-m^/MINIMAL_RECOMPILATION^ -@cindex @option{^-m^/MINIMAL_RECOMPILATION^} (@command{gnatmake}) +@item -m +@cindex @option{-m} (@command{gnatmake}) Specify that the minimum necessary amount of recompilations be performed. In this mode @command{gnatmake} ignores time stamp differences when the only @@ -9838,64 +9339,64 @@ out of date with respect to the sources if the @option{-m} switch causes a compilation to be switched, so the use of this switch represents a trade-off between compilation time and accurate debugging information. -@item ^-M^/DEPENDENCIES_LIST^ +@item -M @cindex Dependencies, producing list -@cindex @option{^-M^/DEPENDENCIES_LIST^} (@command{gnatmake}) +@cindex @option{-M} (@command{gnatmake}) Check if all objects are up to date. If they are, output the object dependences to @file{stdout} in a form that can be directly exploited in a @file{Makefile}. By default, each source file is prefixed with its (relative or absolute) directory name. This name is whatever you -specified in the various @option{^-aI^/SOURCE_SEARCH^} -and @option{^-I^/SEARCH^} switches. If you use -@code{gnatmake ^-M^/DEPENDENCIES_LIST^} -@option{^-q^/QUIET^} +specified in the various @option{-aI} +and @option{-I} switches. If you use +@code{gnatmake -M} +@option{-q} (see below), only the source file names, without relative paths, are output. If you just specify the -@option{^-M^/DEPENDENCIES_LIST^} +@option{-M} switch, dependencies of the GNAT internal system files are omitted. This is typically what you want. If you also specify -the @option{^-a^/ALL_FILES^} switch, +the @option{-a} switch, dependencies of the GNAT internal files are also listed. Note that dependencies of the objects in external Ada libraries (see switch -@option{^-aL^/SKIP_MISSING=^}@var{dir} in the following list) +@option{-aL}@var{dir} in the following list) are never reported. -@item ^-n^/DO_OBJECT_CHECK^ -@cindex @option{^-n^/DO_OBJECT_CHECK^} (@command{gnatmake}) +@item -n +@cindex @option{-n} (@command{gnatmake}) Don't compile, bind, or link. Checks if all objects are up to date. If they are not, the full name of the first file that needs to be recompiled is printed. Repeated use of this option, followed by compiling the indicated source file, will eventually result in recompiling all required units. -@item ^-o ^/EXECUTABLE=^@var{exec_name} -@cindex @option{^-o^/EXECUTABLE^} (@command{gnatmake}) +@item -o @var{exec_name} +@cindex @option{-o} (@command{gnatmake}) Output executable name. The name of the final executable program will be -@var{exec_name}. If the @option{^-o^/EXECUTABLE^} switch is omitted the default +@var{exec_name}. If the @option{-o} switch is omitted the default name for the executable will be the name of the input file in appropriate form for an executable file on the host system. This switch cannot be used when invoking @command{gnatmake} with several @file{file_names}. -@item ^-p or --create-missing-dirs^/CREATE_MISSING_DIRS^ -@cindex @option{^-p^/CREATE_MISSING_DIRS^} (@command{gnatmake}) -When using project files (^-P^/PROJECT_FILE=^@var{project}), create +@item -p or --create-missing-dirs +@cindex @option{-p} (@command{gnatmake}) +When using project files (-P@var{project}), create automatically missing object directories, library directories and exec directories. -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (@command{gnatmake}) +@item -P@var{project} +@cindex @option{-P} (@command{gnatmake}) Use project file @var{project}. Only one such switch can be used. @xref{gnatmake and Project Files}. -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@command{gnatmake}) +@item -q +@cindex @option{-q} (@command{gnatmake}) Quiet. When this flag is not set, the commands carried out by @command{gnatmake} are displayed. -@item ^-s^/SWITCH_CHECK/^ -@cindex @option{^-s^/SWITCH_CHECK^} (@command{gnatmake}) +@item -s +@cindex @option{-s} (@command{gnatmake}) Recompile if compiler switches have changed since last compilation. All compiler switches but -I and -o are taken into account in the following way: @@ -9906,60 +9407,60 @@ is equivalent to @option{-O -g}. This switch is recommended when Integrated Preprocessing is used. -@item ^-u^/UNIQUE^ -@cindex @option{^-u^/UNIQUE^} (@command{gnatmake}) +@item -u +@cindex @option{-u} (@command{gnatmake}) 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^/UNIQUE^ with a project file and no main has a special meaning +-u with a project file and no main has a special meaning (@pxref{Project Files and Main Subprograms}). -@item ^-U^/ALL_PROJECTS^ -@cindex @option{^-U^/ALL_PROJECTS^} (@command{gnatmake}) +@item -U +@cindex @option{-U} (@command{gnatmake}) When used without a project file or with one or several mains on the command -line, is equivalent to ^-u^/UNIQUE^. When used with a project file and no main +line, is equivalent to -u. When used with a project file and no main on the command line, all sources of all project files are checked and compiled if not up to date, and libraries are rebuilt, if necessary. -@item ^-v^/REASONS^ -@cindex @option{^-v^/REASONS^} (@command{gnatmake}) +@item -v +@cindex @option{-v} (@command{gnatmake}) Verbose. Display the reason for all recompilations @command{gnatmake} decides are necessary, with the highest verbosity level. -@item ^-vl^/LOW_VERBOSITY^ -@cindex @option{^-vl^/LOW_VERBOSITY^} (@command{gnatmake}) +@item -vl +@cindex @option{-vl} (@command{gnatmake}) Verbosity level Low. Display fewer lines than in verbosity Medium. -@item ^-vm^/MEDIUM_VERBOSITY^ -@cindex @option{^-vm^/MEDIUM_VERBOSITY^} (@command{gnatmake}) +@item -vm +@cindex @option{-vm} (@command{gnatmake}) Verbosity level Medium. Potentially display fewer lines than in verbosity High. -@item ^-vh^/HIGH_VERBOSITY^ -@cindex @option{^-vm^/HIGH_VERBOSITY^} (@command{gnatmake}) -Verbosity level High. Equivalent to ^-v^/REASONS^. +@item -vh +@cindex @option{-vm} (@command{gnatmake}) +Verbosity level High. Equivalent to -v. -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} +@item -vP@emph{x} Indicate the verbosity of the parsing of GNAT project files. @xref{Switches Related to Project Files}. -@item ^-x^/NON_PROJECT_UNIT_COMPILATION^ -@cindex @option{^-x^/NON_PROJECT_UNIT_COMPILATION^} (@command{gnatmake}) +@item -x +@cindex @option{-x} (@command{gnatmake}) Indicate that sources that are not part of any Project File may be compiled. Normally, when using Project Files, only sources that are part of a Project File may be compile. When this switch is used, a source outside of all Project Files may be compiled. The ALI file and the object file will be put in the object directory of the main Project. The compilation switches used will only be those specified on the command line. Even when -@option{^-x^/NON_PROJECT_UNIT_COMPILATION^} is used, mains specified on the +@option{-x} is used, mains specified on the command line need to be sources of a project file. -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} +@item -X@var{name=value} Indicate that external variable @var{name} has the value @var{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. @xref{Switches Related to Project Files}. -@item ^-z^/NOMAIN^ -@cindex @option{^-z^/NOMAIN^} (@command{gnatmake}) +@item -z +@cindex @option{-z} (@command{gnatmake}) No main subprogram. Bind and link the program even if the unit name given on the command line is a package name. The resulting executable will execute the elaboration routines of the package and its closure, @@ -9969,16 +9470,8 @@ then the finalization routines. @table @asis @item @command{gcc} @asis{switches} -@ifclear vms Any uppercase or multi-character switch that is not a @command{gnatmake} switch is passed to @command{gcc} (e.g.@: @option{-O}, @option{-gnato,} etc.) -@end ifclear -@ifset vms -Any qualifier that cannot be recognized as a qualifier for @code{GNAT MAKE} -but is recognizable as a valid qualifier for @code{GNAT COMPILE} is -automatically treated as a compiler switch, and passed on to all -compilations that are carried out. -@end ifset @end table @noindent @@ -9986,62 +9479,60 @@ Source and library search path switches: @table @option @c !sort! -@item ^-aI^/SOURCE_SEARCH=^@var{dir} -@cindex @option{^-aI^/SOURCE_SEARCH^} (@command{gnatmake}) +@item -aI@var{dir} +@cindex @option{-aI} (@command{gnatmake}) When looking for source files also look in directory @var{dir}. The order in which source files search is undertaken is described in @ref{Search Paths and the Run-Time Library (RTL)}. -@item ^-aL^/SKIP_MISSING=^@var{dir} -@cindex @option{^-aL^/SKIP_MISSING^} (@command{gnatmake}) +@item -aL@var{dir} +@cindex @option{-aL} (@command{gnatmake}) Consider @var{dir} as being an externally provided Ada library. Instructs @command{gnatmake} to skip compilation units whose @file{.ALI} files have been located in directory @var{dir}. This allows you to have missing bodies for the units in @var{dir} and to ignore out of date bodies for the same units. You still need to specify the location of the specs for these units by using the switches -@option{^-aI^/SOURCE_SEARCH=^@var{dir}} -or @option{^-I^/SEARCH=^@var{dir}}. +@option{-aI@var{dir}} +or @option{-I@var{dir}}. Note: this switch is provided for compatibility with previous versions of @command{gnatmake}. The easier method of causing standard libraries to be excluded from consideration is to write-protect the corresponding ALI files. -@item ^-aO^/OBJECT_SEARCH=^@var{dir} -@cindex @option{^-aO^/OBJECT_SEARCH^} (@command{gnatmake}) +@item -aO@var{dir} +@cindex @option{-aO} (@command{gnatmake}) When searching for library and object files, look in directory @var{dir}. The order in which library files are searched is described in @ref{Search Paths for gnatbind}. -@item ^-A^/CONDITIONAL_SOURCE_SEARCH=^@var{dir} +@item -A@var{dir} @cindex Search paths, for @command{gnatmake} -@cindex @option{^-A^/CONDITIONAL_SOURCE_SEARCH^} (@command{gnatmake}) -Equivalent to @option{^-aL^/SKIP_MISSING=^@var{dir} -^-aI^/SOURCE_SEARCH=^@var{dir}}. +@cindex @option{-A} (@command{gnatmake}) +Equivalent to @option{-aL@var{dir} +-aI@var{dir}}. -@item ^-I^/SEARCH=^@var{dir} -@cindex @option{^-I^/SEARCH^} (@command{gnatmake}) -Equivalent to @option{^-aO^/OBJECT_SEARCH=^@var{dir} -^-aI^/SOURCE_SEARCH=^@var{dir}}. +@item -I@var{dir} +@cindex @option{-I} (@command{gnatmake}) +Equivalent to @option{-aO@var{dir} +-aI@var{dir}}. -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gnatmake}) +@item -I- +@cindex @option{-I-} (@command{gnatmake}) @cindex Source files, suppressing search Do not look for source files in the directory containing the source file named in the command line. Do not look for ALI or object files in the directory where @command{gnatmake} was invoked. -@item ^-L^/LIBRARY_SEARCH=^@var{dir} -@cindex @option{^-L^/LIBRARY_SEARCH^} (@command{gnatmake}) +@item -L@var{dir} +@cindex @option{-L} (@command{gnatmake}) @cindex Linker libraries Add directory @var{dir} to the list of directories in which the linker will search for libraries. This is equivalent to -@option{-largs ^-L^/LIBRARY_SEARCH=^}@var{dir}. -@ifclear vms +@option{-largs -L}@var{dir}. Furthermore, under Windows, the sources pointed to by the libraries path set in the registry are not searched for. -@end ifclear @item -nostdinc @cindex @option{-nostdinc} (@command{gnatmake}) @@ -10133,11 +9624,11 @@ is a subunit or body of a generic unit, @command{gnatmake} recompiles warning. @item -In @command{gnatmake} the switch @option{^-I^/SEARCH^} +In @command{gnatmake} the switch @option{-I} is used to specify both source and -library file paths. Use @option{^-aI^/SOURCE_SEARCH^} +library file paths. Use @option{-aI} instead if you just want to specify -source paths only and @option{^-aO^/OBJECT_SEARCH^} +source paths only and @option{-aO} if you want to specify library paths only. @@ -10145,31 +9636,25 @@ only. @command{gnatmake} will ignore any files whose ALI file is write-protected. This may conveniently be used to exclude standard libraries from consideration and in particular it means that the use of the -@option{^-f^/FORCE_COMPILE^} switch will not recompile these files -unless @option{^-a^/ALL_FILES^} is also specified. +@option{-f} switch will not recompile these files +unless @option{-a} is also specified. @item @command{gnatmake} has been designed to make the use of Ada libraries particularly convenient. Assume you have an Ada library organized -as follows: @i{^obj-dir^[OBJ_DIR]^} contains the objects and ALI files for +as follows: @i{obj-dir} contains the objects and ALI files for of your Ada compilation units, -whereas @i{^include-dir^[INCLUDE_DIR]^} contains the +whereas @i{include-dir} contains the specs of these units, but no bodies. Then to compile a unit stored in @code{main.adb}, which uses this Ada library you would just type @smallexample -@ifclear vms $ gnatmake -aI@var{include-dir} -aL@var{obj-dir} main -@end ifclear -@ifset vms -$ gnatmake /SOURCE_SEARCH=@i{[INCLUDE_DIR]} - /SKIP_MISSING=@i{[OBJ_DIR]} main -@end ifset @end smallexample @item Using @command{gnatmake} along with the -@option{^-m (minimal recompilation)^/MINIMAL_RECOMPILATION^} +@option{-m (minimal recompilation)} switch provides a mechanism for avoiding unnecessary recompilations. Using this switch, you can update the comments/format of your @@ -10227,7 +9712,7 @@ Note: when using non-standard naming conventions file the version of a source and invoking @command{gnatmake} to recompile may have no effect, if the previous version of the source is still accessible by @command{gnatmake}. It may be necessary to use the switch -^-f^/FORCE_COMPILE^. +-f. @node Examples of gnatmake Usage @section Examples of @command{gnatmake} Usage @@ -10236,26 +9721,19 @@ by @command{gnatmake}. It may be necessary to use the switch @item gnatmake hello.adb Compile all files necessary to bind and link the main program @file{hello.adb} (containing unit @code{Hello}) and bind and link the -resulting object files to generate an executable file @file{^hello^HELLO.EXE^}. +resulting object files to generate an executable file @file{hello}. @item gnatmake main1 main2 main3 Compile all files necessary to bind and link the main programs @file{main1.adb} (containing unit @code{Main1}), @file{main2.adb} (containing unit @code{Main2}) and @file{main3.adb} (containing unit @code{Main3}) and bind and link the resulting object files -to generate three executable files @file{^main1^MAIN1.EXE^}, -@file{^main2^MAIN2.EXE^} -and @file{^main3^MAIN3.EXE^}. +to generate three executable files @file{main1}, +@file{main2} +and @file{main3}. -@ifclear vms @item gnatmake -q Main_Unit -cargs -O2 -bargs -l -@end ifclear -@ifset vms -@item gnatmake Main_Unit /QUIET -/COMPILER_QUALIFIERS /OPTIMIZE=ALL -/BINDER_QUALIFIERS /ORDER_OF_ELABORATION -@end ifset Compile all files necessary to bind and link the main program unit @code{Main_Unit} (from file @file{main_unit.adb}). All compilations will be done with optimization level 2 and the order of elaboration will be @@ -10346,9 +9824,6 @@ some guidelines on debugging optimized code. * Atomic Variables and Optimization:: * Passive Task Optimization:: -@ifset vms -* Coverage Analysis:: -@end ifset @end menu @node Controlling Run-Time Checks @@ -10421,8 +9896,8 @@ constructs and controlled types will show much improved performance. The relevant restrictions pragmas are @smallexample @c ada - pragma Restrictions (No_Abort_Statements); - pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + @b{pragma} Restrictions (No_Abort_Statements); + @b{pragma} Restrictions (Max_Asynchronous_Select_Nesting => 0); @end smallexample @noindent @@ -10432,10 +9907,10 @@ possibility of an immediate abort at any point. @node Optimization Levels @subsection Optimization Levels -@cindex @option{^-O^/OPTIMIZE^} (@command{gcc}) +@cindex @option{-O} (@command{gcc}) @noindent -Without any optimization ^option,^qualifier,^ +Without any optimization option, the compiler's goal is to reduce the cost of compilation and to make debugging produce the expected results. Statements are independent: if you stop the program with a breakpoint between @@ -10448,7 +9923,7 @@ performance and/or code size at the expense of compilation time and possibly the ability to debug the program. If you use multiple -^-O options, with or without level numbers,^/OPTIMIZE qualifiers,^ +-O options, with or without level numbers, the last such option is the one that is effective. @noindent @@ -10456,48 +9931,40 @@ The default is optimization off. This results in the fastest compile times, but GNAT makes absolutely no attempt to optimize, and the generated programs are considerably larger and slower than when optimization is enabled. You can use the -@ifclear vms @option{-O} switch (the permitted forms are @option{-O0}, @option{-O1} @option{-O2}, @option{-O3}, and @option{-Os}) -@end ifclear -@ifset vms -@code{OPTIMIZE} qualifier -@end ifset to @command{gcc} to control the optimization level: @table @option -@item ^-O0^/OPTIMIZE=NONE^ +@item -O0 No optimization (the default); generates unoptimized code but has the fastest compilation time. Note that many other compilers do fairly extensive optimization even if ``no optimization'' is specified. With gcc, it is -very unusual to use ^-O0^/OPTIMIZE=NONE^ for production if -execution time is of any concern, since ^-O0^/OPTIMIZE=NONE^ +very unusual to use -O0 for production if +execution time is of any concern, since -O0 really does mean no optimization at all. This difference between gcc and other compilers should be kept in mind when doing performance comparisons. -@item ^-O1^/OPTIMIZE=SOME^ +@item -O1 Moderate optimization; optimizes reasonably well but does not degrade compilation time significantly. -@item ^-O2^/OPTIMIZE=ALL^ -@ifset vms -@itemx /OPTIMIZE=DEVELOPMENT -@end ifset +@item -O2 Full optimization; generates highly optimized code and has the slowest compilation time. -@item ^-O3^/OPTIMIZE=INLINING^ +@item -O3 Full optimization as in @option{-O2}; also uses more aggressive automatic inlining of subprograms within a unit (@pxref{Inlining of Subprograms}) and attempts to vectorize loops. -@item ^-Os^/OPTIMIZE=SPACE^ +@item -Os Optimize space usage (code and data) of resulting program. @end table @@ -10514,10 +9981,10 @@ release to release (and sometime from target to target), it is best to think of the optimization settings in general terms. @xref{Optimize Options,, Options That Control Optimization, gcc, Using the GNU Compiler Collection (GCC)}, for details about -^the @option{-O} settings and a number of @option{-f} options that^how to^ +the @option{-O} settings and a number of @option{-f} options that individually enable or disable specific optimizations. -Unlike some other compilation systems, ^@command{gcc}^GNAT^ has +Unlike some other compilation systems, @command{gcc} has been tested extensively at all optimization levels. There are some bugs which appear only with optimization turned on, but there have also been bugs which show up only in @emph{unoptimized} code. Selecting a lower @@ -10537,24 +10004,18 @@ in @ref{Inlining of Subprograms}. @noindent Although it is possible to do a reasonable amount of debugging at -@ifclear vms nonzero optimization levels, the higher the level the more likely that -@end ifclear -@ifset vms -@option{/OPTIMIZE} settings other than @code{NONE}, -such settings will make it more likely that -@end ifset source-level constructs will have been eliminated by optimization. For example, if a loop is strength-reduced, the loop control variable may be completely eliminated and thus cannot be displayed in the debugger. This can only happen at @option{-O2} or @option{-O3}. Explicit temporary variables that you code might be eliminated at -^level^setting^ @option{-O1} or higher. +level @option{-O1} or higher. -The use of the @option{^-g^/DEBUG^} switch, -@cindex @option{^-g^/DEBUG^} (@command{gcc}) +The use of the @option{-g} switch, +@cindex @option{-g} (@command{gcc}) which is needed for source-level debugging, affects the size of the program executable on disk, and indeed the debugging information can be quite large. @@ -10602,7 +10063,7 @@ jumps to a statement that is not supposed to be executed, simply because it (and the code following) translates to the same thing as the code that @emph{was} supposed to be executed. This effect is typically seen in sequences that end in a jump, such as a @code{goto}, a @code{return}, or -a @code{break} in a C @code{^switch^switch^} statement. +a @code{break} in a C @code{switch} statement. @item @i{The ``roving variable'':} The symptom is an unexpected value in a variable. @@ -10650,13 +10111,11 @@ In light of such anomalies, a recommended technique is to use @option{-O0} early in the software development cycle, when extensive debugging capabilities are most needed, and then move to @option{-O1} and later @option{-O2} as the debugger becomes less critical. -Whether to use the @option{^-g^/DEBUG^} switch in the release version is +Whether to use the @option{-g} switch in the release version is a release management issue. -@ifclear vms Note that if you use @option{-g} you can then use the @command{strip} program on the resulting executable, which removes both debugging information and global symbols. -@end ifclear @node Inlining of Subprograms @subsection Inlining of Subprograms @@ -10678,7 +10137,7 @@ subprograms. @cindex pragma Inline @findex Inline Any one of the following applies: @code{pragma Inline} is applied to the -subprogram and the @option{^-gnatn^/INLINE^} switch is specified; the +subprogram and the @option{-gnatn} switch is specified; the subprogram is local to the unit and called once from within it; the subprogram is small and optimization level @option{-O2} is specified; optimization level @option{-O3} is specified. @@ -10705,7 +10164,7 @@ The call appears in a body (not in a package spec). There is a @code{pragma Inline} for the subprogram. @item -The @option{^-gnatn^/INLINE^} switch is used on the command line. +The @option{-gnatn} switch is used on the command line. @end itemize Even if all these conditions are met, it may not be possible for @@ -10718,20 +10177,20 @@ compilation dependencies. Consider the following: @smallexample @c ada @cartouche -package R is - procedure Q; - pragma Inline (Q); -end R; -package body R is +@b{package} R @b{is} + @b{procedure} Q; + @b{pragma} Inline (Q); +@b{end} R; +@b{package} @b{body} R @b{is} @dots{} -end R; +@b{end} R; -with R; -procedure Main is -begin +@b{with} R; +@b{procedure} Main @b{is} +@b{begin} @dots{} R.Q; -end Main; +@b{end} Main; @end cartouche @end smallexample @@ -10753,8 +10212,8 @@ occurs whether or not the call is in fact inlined by @command{gcc}. The use of front end inlining with @option{-gnatN} generates similar additional dependencies. -@cindex @option{^-fno-inline^/INLINE=SUPPRESS^} (@command{gcc}) -Note: The @option{^-fno-inline^/INLINE=SUPPRESS^} switch +@cindex @option{-fno-inline} (@command{gcc}) +Note: The @option{-fno-inline} switch can be used to prevent all inlining. This switch overrides all other conditions and ensures that no inlining occurs. The extra dependences resulting from @@ -10816,17 +10275,17 @@ contain a single nested loop, if it can be vectorized when considered alone: @smallexample @c ada @cartouche - A : array (1..4, 1..4) of Long_Float; - S : array (1..4) of Long_Float; + A : @b{array} (1..4, 1..4) @b{of} Long_Float; + S : @b{array} (1..4) @b{of} Long_Float; - procedure Sum is - begin - for I in A'Range(1) loop - for J in A'Range(2) loop + @b{procedure} Sum @b{is} + @b{begin} + @b{for} I @b{in} A'Range(1) @b{loop} + @b{for} J @b{in} A'Range(2) @b{loop} S (I) := S (I) + A (I, J); - end loop; - end loop; - end Sum; + @b{end} @b{loop}; + @b{end} @b{loop}; + @b{end} Sum; @end cartouche @end smallexample @@ -10855,25 +10314,25 @@ All kinds of array types are supported, i.e. constrained array types with static bounds: @smallexample @c ada - type Array_Type is array (1 .. 4) of Long_Float; + @b{type} Array_Type @b{is} @b{array} (1 .. 4) @b{of} Long_Float; @end smallexample @noindent constrained array types with dynamic bounds: @smallexample @c ada - type Array_Type is array (1 .. Q.N) of Long_Float; + @b{type} Array_Type @b{is} @b{array} (1 .. Q.N) @b{of} Long_Float; - type Array_Type is array (Q.K .. 4) of Long_Float; + @b{type} Array_Type @b{is} @b{array} (Q.K .. 4) @b{of} Long_Float; - type Array_Type is array (Q.K .. Q.N) of Long_Float; + @b{type} Array_Type @b{is} @b{array} (Q.K .. Q.N) @b{of} Long_Float; @end smallexample @noindent or unconstrained array types: @smallexample @c ada - type Array_Type is array (Positive range <>) of Long_Float; + @b{type} Array_Type @b{is} @b{array} (Positive @b{range} <>) @b{of} Long_Float; @end smallexample @noindent @@ -10887,7 +10346,7 @@ It is possible to specify that a given loop should be subject to vectorization preferably to other optimizations by means of pragma @code{Loop_Optimize}: @smallexample @c ada - pragma Loop_Optimize (Vector); + @b{pragma} Loop_Optimize (Vector); @end smallexample @noindent @@ -10899,27 +10358,27 @@ for a given loop by asserting that there are no loop-carried dependencies in the loop. Consider for example the procedure: @smallexample @c ada - type Arr is array (1 .. 4) of Long_Float; + @b{type} Arr @b{is} @b{array} (1 .. 4) @b{of} Long_Float; - procedure Add (X, Y : not null access Arr; R : not null access Arr) is - begin - for I in Arr'Range loop + @b{procedure} Add (X, Y : @b{not} @b{null} @b{access} Arr; R : @b{not} @b{null} @b{access} Arr) @b{is} + @b{begin} + @b{for} I @b{in} Arr'Range @b{loop} R(I) := X(I) + Y(I); - end loop; - end; + @b{end} @b{loop}; + @b{end}; @end smallexample @noindent By default, the compiler cannot unconditionally vectorize the loop because assigning to a component of the array designated by R in one iteration could -change the value read from the components of the arrays designated by X or Y +change the value read from the components of the array designated by X or Y in a later iteration. As a result, the compiler will generate two versions of the loop in the object code, one vectorized and the other not vectorized, as well as a test to select the appropriate version at run time. This can be overcome by another hint: @smallexample @c ada - pragma Loop_Optimize (Ivdep); + @b{pragma} Loop_Optimize (Ivdep); @end smallexample @noindent @@ -10954,24 +10413,24 @@ the following example: @smallexample @c ada @cartouche -procedure R is - type Int1 is new Integer; - type Int2 is new Integer; - type Int1A is access Int1; - type Int2A is access Int2; +@b{procedure} R @b{is} + @b{type} Int1 @b{is} @b{new} Integer; + @b{type} Int2 @b{is} @b{new} Integer; + @b{type} Int1A @b{is} @b{access} Int1; + @b{type} Int2A @b{is} @b{access} Int2; Int1V : Int1A; Int2V : Int2A; @dots{} -begin +@b{begin} @dots{} - for J in Data'Range loop - if Data (J) = Int1V.all then - Int2V.all := Int2V.all + 1; - end if; - end loop; + @b{for} J @b{in} Data'Range @b{loop} + @b{if} Data (J) = Int1V.@b{all} @b{then} + Int2V.@b{all} := Int2V.@b{all} + 1; + @b{end} @b{if}; + @b{end} @b{loop}; @dots{} -end R; +@b{end} R; @end cartouche @end smallexample @@ -10996,39 +10455,39 @@ the typing system. Consider the following complete program example: @smallexample @c ada @cartouche -package p1 is - type int1 is new integer; - type int2 is new integer; - type a1 is access int1; - type a2 is access int2; -end p1; - -with p1; use p1; -package p2 is - function to_a2 (Input : a1) return a2; -end p2; - -with Unchecked_Conversion; -package body p2 is - function to_a2 (Input : a1) return a2 is - function to_a2u is - new Unchecked_Conversion (a1, a2); - begin - return to_a2u (Input); - end to_a2; -end p2; - -with p2; use p2; -with p1; use p1; -with Text_IO; use Text_IO; -procedure m is - v1 : a1 := new int1; +@b{package} p1 @b{is} + @b{type} int1 @b{is} @b{new} integer; + @b{type} int2 @b{is} @b{new} integer; + @b{type} a1 @b{is} @b{access} int1; + @b{type} a2 @b{is} @b{access} int2; +@b{end} p1; + +@b{with} p1; @b{use} p1; +@b{package} p2 @b{is} + @b{function} to_a2 (Input : a1) @b{return} a2; +@b{end} p2; + +@b{with} Unchecked_Conversion; +@b{package} @b{body} p2 @b{is} + @b{function} to_a2 (Input : a1) @b{return} a2 @b{is} + @b{function} to_a2u @b{is} + @b{new} Unchecked_Conversion (a1, a2); + @b{begin} + @b{return} to_a2u (Input); + @b{end} to_a2; +@b{end} p2; + +@b{with} p2; @b{use} p2; +@b{with} p1; @b{use} p1; +@b{with} Text_IO; @b{use} Text_IO; +@b{procedure} m @b{is} + v1 : a1 := @b{new} int1; v2 : a2 := to_a2 (v1); -begin - v1.all := 1; - v2.all := 0; - put_line (int1'image (v1.all)); -end; +@b{begin} + v1.@b{all} := 1; + v2.@b{all} := 0; + put_line (int1'image (v1.@b{all})); +@b{end}; @end cartouche @end smallexample @@ -11106,10 +10565,10 @@ instantiation of @code{Unchecked_Conversion} to turn the warning off: @smallexample @c ada - pragma Warnings (Off); - function to_a2u is - new Unchecked_Conversion (a1, a2); - pragma Warnings (On); + @b{pragma} Warnings (Off); + @b{function} to_a2u @b{is} + @b{new} Unchecked_Conversion (a1, a2); + @b{pragma} Warnings (On); @end smallexample @noindent @@ -11134,8 +10593,8 @@ source type is not visible in that unit), you may use pragma same declarative sequence as the declaration of the access type: @smallexample @c ada - type a2 is access int2; - pragma No_Strict_Aliasing (a2); + @b{type} a2 @b{is} @b{access} int2; + @b{pragma} No_Strict_Aliasing (a2); @end smallexample @noindent @@ -11182,27 +10641,27 @@ variable's value, even though it is passed as an IN parameter. Consider the following example: @smallexample @c ada -procedure P is - Max_Length : constant Natural := 16; - type Char_Ptr is access all Character; +@b{procedure} P @b{is} + Max_Length : @b{constant} Natural := 16; + @b{type} Char_Ptr @b{is} @b{access} @b{all} Character; - procedure Get_String(Buffer: Char_Ptr; Size : Integer); - pragma Import (C, Get_String, "get_string"); + @b{procedure} Get_String(Buffer: Char_Ptr; Size : Integer); + @b{pragma} Import (C, Get_String, "get_string"); - Name : aliased String (1 .. Max_Length) := (others => ' '); + Name : @b{aliased} String (1 .. Max_Length) := (@b{others} => ' '); Temp : Char_Ptr; - function Addr (S : String) return Char_Ptr is - function To_Char_Ptr is - new Ada.Unchecked_Conversion (System.Address, Char_Ptr); - begin - return To_Char_Ptr (S (S'First)'Address); - end; + @b{function} Addr (S : String) @b{return} Char_Ptr @b{is} + @b{function} To_Char_Ptr @b{is} + @b{new} Ada.Unchecked_Conversion (System.Address, Char_Ptr); + @b{begin} + @b{return} To_Char_Ptr (S (S'First)'Address); + @b{end}; -begin +@b{begin} Temp := Addr (Name); Get_String (Temp, Max_Length); -end; +@b{end}; @end smallexample @noindent @@ -11241,14 +10700,14 @@ assume that the entire variable will always be accessed. Consider this example: @smallexample @c ada -type R is record +@b{type} R @b{is} @b{record} A,B,C,D : Character; -end record; -for R'Size use 32; -for R'Alignment use 4; +@b{end} @b{record}; +@b{for} R'Size @b{use} 32; +@b{for} R'Alignment @b{use} 4; RV : R; -pragma Atomic (RV); +@b{pragma} Atomic (RV); X : Character; ... X := RV.B; @@ -11270,11 +10729,11 @@ example be full 32-bit loads, you need to make a copy for the access as in: @smallexample @c ada -declare - RV_Copy : constant R := RV; -begin +@b{declare} + RV_Copy : @b{constant} R := RV; +@b{begin} X := RV_Copy.B; -end; +@b{end}; @end smallexample @@ -11338,15 +10797,6 @@ arise, and update those particular tasks to be protected types. Note that typically clients of the tasks who call entries, will not have to be modified, only the task definition itself. -@ifset vms -@node Coverage Analysis -@subsection Coverage Analysis - -@noindent -GNAT supports the HP Performance Coverage Analyzer (PCA), which allows -the user to determine the distribution of execution time across a program, -@pxref{Profiling} for details of usage. -@end ifset @node Text_IO Suggestions @@ -11418,11 +10868,17 @@ After a full successful build of the main subprogram @code{gnatelim} can be called without specifying sources to analyse, in this case it computes the source closure of the main unit from the @file{ALI} files. +If the set of sources to be processed by @code{gnatelim} contains sources with +preprocessing directives +then the needed options should be provided to run preprocessor as a part of +the @command{gnatelim} call, and the generated set of pragmas @code{Eliminate} +will correspond to preprocessed sources. + The following command will create the set of @file{ALI} files needed for @code{gnatelim}: @smallexample -$ gnatmake ^-c Main_Prog^/ACTIONS=COMPILE MAIN_PROG^ +$ gnatmake -c Main_Prog @end smallexample Note that @code{gnatelim} does not need object files. @@ -11434,7 +10890,7 @@ Note that @code{gnatelim} does not need object files. @code{gnatelim} has the following command-line interface: @smallexample -$ gnatelim [@var{switches}] ^-main^?MAIN^=@var{main_unit_name} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} +$ gnatelim [@var{switches}] -main=@var{main_unit_name} @{@var{filename}@} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent @@ -11448,7 +10904,7 @@ the file name may contain path information. @samp{@var{gcc_switches}} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatelim} to generate the ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +@option{-I} switches to form the source search path, use the @option{-gnatec} switch to set the configuration file, use the @option{-gnat05} switch if sources should be compiled in Ada 2005 mode etc. @@ -11476,66 +10932,66 @@ Indicates that external variable @var{name} in the argument project has the value @var{value}. Has no effect if no project is specified as tool argument. -@item ^-files^/FILES^=@var{filename} -@cindex @option{^-files^/FILES^} (@code{gnatelim}) +@item -files=@var{filename} +@cindex @option{-files} (@code{gnatelim}) Take the argument source files from the specified file. This file should be an ordinary text file containing file names separated by spaces or line breaks. You can use this switch more than once in the same call to @command{gnatelim}. You also can combine this switch with an explicit list of files. -@item ^-log^/LOG^ -@cindex @option{^-log^/LOG^} (@command{gnatelim}) +@item -log +@cindex @option{-log} (@command{gnatelim}) Duplicate all the output sent to @file{stderr} into a log file. The log file is named @file{gnatelim.log} and is located in the current directory. @ignore -@item ^-log^/LOGFILE^=@var{filename} -@cindex @option{^-log^/LOGFILE^} (@command{gnatelim}) +@item -log=@var{filename} +@cindex @option{-log} (@command{gnatelim}) Duplicate all the output sent to @file{stderr} into a specified log file. @end ignore -@cindex @option{^--no-elim-dispatch^/NO_DISPATCH^} (@command{gnatelim}) -@item ^--no-elim-dispatch^/NO_DISPATCH^ +@cindex @option{--no-elim-dispatch} (@command{gnatelim}) +@item --no-elim-dispatch Do not generate pragmas for dispatching operations. -@item ^--ignore^/IGNORE^=@var{filename} -@cindex @option{^--ignore^/IGNORE^} (@command{gnatelim}) +@item --ignore=@var{filename} +@cindex @option{--ignore} (@command{gnatelim}) Do not generate pragmas for subprograms declared in the sources listed in a specified file -@cindex @option{^-o^/OUTPUT^} (@command{gnatelim}) -@item ^-o^/OUTPUT^=@var{report_file} +@cindex @option{-o} (@command{gnatelim}) +@item -o=@var{report_file} Put @command{gnatelim} output into a specified file. If this file already exists, it is overridden. If this switch is not used, @command{gnatelim} outputs its results into @file{stderr} -@item ^-j^/PROCESSES=^@var{n} -@cindex @option{^-j^/PROCESSES^} (@command{gnatelim}) +@item -j@var{n} +@cindex @option{-j} (@command{gnatelim}) Use @var{n} processes to carry out the tree creations (internal representations of the argument sources). On a multiprocessor machine this speeds up processing of big sets of argument sources. If @var{n} is 0, then the maximum number of parallel tree creations is the number of core processors on the platform. -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@command{gnatelim}) +@item -q +@cindex @option{-q} (@command{gnatelim}) Quiet mode: by default @code{gnatelim} outputs to the standard error stream the number of program units left to be processed. This option turns this trace off. -@cindex @option{^-t^/TIME^} (@command{gnatelim}) -@item ^-t^/TIME^ +@cindex @option{-t} (@command{gnatelim}) +@item -t Print out execution time. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@command{gnatelim}) +@item -v +@cindex @option{-v} (@command{gnatelim}) Verbose mode: @code{gnatelim} version information is printed as Ada comments to the standard output stream. Also, in addition to the number of program units left @code{gnatelim} will output the name of the current unit being processed. -@item ^-wq^/WARNINGS=QUIET^ -@cindex @option{^-wq^/WARNINGS=QUIET^} (@command{gnatelim}) +@item -wq +@cindex @option{-wq} (@command{gnatelim}) Quiet warning mode - some warnings are suppressed. In particular warnings that indicate that the analysed set of sources is incomplete to make up a partition and that some subprogram bodies are missing are not generated. @@ -11553,7 +11009,7 @@ If some program uses a precompiled Ada library, it can be processed by @code{gnatelim} in a usual way. @code{gnatelim} will newer generate an Eliminate pragma for a subprogram if the body of this subprogram has not been analysed, this is a typical case for subprograms from precompiled -libraries. Switch @option{^-wq^/WARNINGS=QUIET^} may be used to suppress +libraries. Switch @option{-wq} may be used to suppress warnings about missing source files and non-analyzed subprogram bodies that can be generated when processing precompiled Ada libraries. @@ -11585,11 +11041,11 @@ pragmas Eliminate generated by gnatelim. If these pragmas are placed in @file{gnat.adc} file located in your current directory, just do: @smallexample -$ gnatmake ^-f main_prog^/FORCE_COMPILE MAIN_PROG^ +$ gnatmake -f main_prog @end smallexample @noindent -(Use the @option{^-f^/FORCE_COMPILE^} option for @command{gnatmake} to +(Use the @option{-f} option for @command{gnatmake} to recompile everything with the set of pragmas @code{Eliminate} that you have obtained with @command{gnatelim}). @@ -11613,26 +11069,21 @@ Create a complete set of @file{ALI} files (if the program has not been built already) @smallexample -$ gnatmake ^-c main_prog^/ACTIONS=COMPILE MAIN_PROG^ +$ gnatmake -c main_prog @end smallexample @item Generate a list of @code{Eliminate} pragmas in default configuration file @file{gnat.adc} in the current directory @smallexample -@ifset vms -$ PIPE GNAT ELIM MAIN_PROG > GNAT.ADC -@end ifset -@ifclear vms $ gnatelim main_prog >@r{[}>@r{]} gnat.adc -@end ifclear @end smallexample @item Recompile the application @smallexample -$ gnatmake ^-f main_prog^/FORCE_COMPILE MAIN_PROG^ +$ gnatmake -f main_prog @end smallexample @end enumerate @@ -11709,32 +11160,32 @@ and data of the GNAT library from your executable. Here is a simple example: @smallexample @c ada -with Aux; +@b{with} Aux; -procedure Test is -begin +@b{procedure} Test @b{is} +@b{begin} Aux.Used (10); -end Test; +@b{end} Test; -package Aux is +@b{package} Aux @b{is} Used_Data : Integer; Unused_Data : Integer; - procedure Used (Data : Integer); - procedure Unused (Data : Integer); -end Aux; + @b{procedure} Used (Data : Integer); + @b{procedure} Unused (Data : Integer); +@b{end} Aux; -package body Aux is - procedure Used (Data : Integer) is - begin +@b{package} @b{body} Aux @b{is} + @b{procedure} Used (Data : Integer) @b{is} + @b{begin} Used_Data := Data; - end Used; + @b{end} Used; - procedure Unused (Data : Integer) is - begin + @b{procedure} Unused (Data : Integer) @b{is} + @b{begin} Unused_Data := Data; - end Unused; -end Aux; + @b{end} Unused; +@b{end} Aux; @end smallexample @noindent @@ -11904,13 +11355,13 @@ file called @file{hellofiles} containing @smallexample @c ada @group @cartouche -procedure hello; +@b{procedure} hello; -with Text_IO; use Text_IO; -procedure hello is -begin +@b{with} Text_IO; @b{use} Text_IO; +@b{procedure} hello @b{is} +@b{begin} Put_Line ("Hello"); -end hello; +@b{end} hello; @end cartouche @end group @end smallexample @@ -11919,7 +11370,7 @@ end hello; the command @smallexample -$ gnatchop ^hellofiles^HELLOFILES.^ +$ gnatchop hellofiles @end smallexample @noindent @@ -11940,7 +11391,7 @@ file called @file{toto.txt} containing @smallexample @c ada @group @cartouche --- Just a comment +--@i{ Just a comment} @end cartouche @end group @end smallexample @@ -11949,7 +11400,7 @@ file called @file{toto.txt} containing the command @smallexample -$ gnatchop ^toto.txt^TOT.TXT^ +$ gnatchop toto.txt @end smallexample @noindent @@ -11979,60 +11430,50 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-c^/COMPILATION^ -@cindex @option{^-c^/COMPILATION^} (@code{gnatchop}) +@item -c +@cindex @option{-c} (@code{gnatchop}) Causes @code{gnatchop} to operate in compilation mode, in which configuration pragmas are handled according to strict RM rules. See previous section for a full description of this mode. -@ifclear vms @item -gnat@var{xxx} This passes the given @option{-gnat@var{xxx}} switch to @code{gnat} which is used to parse the given file. Not all @var{xxx} options make sense, but for example, the use of @option{-gnati2} allows @code{gnatchop} to process a source file that uses Latin-2 coding for identifiers. -@end ifclear -@item ^-h^/HELP^ +@item -h Causes @code{gnatchop} to generate a brief help summary to the standard output file showing usage information. -@item ^-k@var{mm}^/FILE_NAME_MAX_LENGTH=@var{mm}^ -@cindex @option{^-k^/FILE_NAME_MAX_LENGTH^} (@code{gnatchop}) +@item -k@var{mm} +@cindex @option{-k} (@code{gnatchop}) Limit generated file names to the specified number @code{mm} of characters. This is useful if the resulting set of files is required to be interoperable with systems which limit the length of file names. -@ifset vms -If no value is given, or -if no @code{/FILE_NAME_MAX_LENGTH} qualifier is given, -a default of 39, suitable for OpenVMS Alpha -Systems, is assumed -@end ifset -@ifclear vms No space is allowed between the @option{-k} and the numeric value. The numeric value may be omitted in which case a default of @option{-k8}, suitable for use with DOS-like file systems, is used. If no @option{-k} switch is present then there is no limit on the length of file names. -@end ifclear -@item ^-p^/PRESERVE^ -@cindex @option{^-p^/PRESERVE^} (@code{gnatchop}) -Causes the file ^modification^creation^ time stamp of the input file to be +@item -p +@cindex @option{-p} (@code{gnatchop}) +Causes the file modification time stamp of the input file to be preserved and used for the time stamp of the output file(s). This may be useful for preserving coherency of time stamps in an environment where @code{gnatchop} is used as part of a standard build process. -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@code{gnatchop}) +@item -q +@cindex @option{-q} (@code{gnatchop}) Causes output of informational messages indicating the set of generated files to be suppressed. Warnings and error messages are unaffected. -@item ^-r^/REFERENCE^ -@cindex @option{^-r^/REFERENCE^} (@code{gnatchop}) +@item -r +@cindex @option{-r} (@code{gnatchop}) @findex Source_Reference Generate @code{Source_Reference} pragmas. Use this switch if the output files are regarded as temporary and development is to be done in terms @@ -12042,7 +11483,7 @@ generated files to refers back to the original file name and line number. The result is that all error messages refer back to the original unchopped file. In addition, the debugging information placed into the object file (when -the @option{^-g^/DEBUG^} switch of @command{gcc} or @command{gnatmake} is +the @option{-g} switch of @command{gcc} or @command{gnatmake} is specified) also refers back to this original file so that tools like profilers and debuggers will give information in terms of the original unchopped file. @@ -12056,14 +11497,14 @@ line numbers. This is particularly useful when @code{gnatchop} is used in conjunction with @code{gnatprep} to compile files that contain preprocessing statements and multiple units. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@code{gnatchop}) +@item -v +@cindex @option{-v} (@code{gnatchop}) Causes @code{gnatchop} to operate in verbose mode. The version number and copyright notice are output, as well as exact copies of the gnat1 commands spawned to obtain the chop control information. -@item ^-w^/OVERWRITE^ -@cindex @option{^-w^/OVERWRITE^} (@code{gnatchop}) +@item -w +@cindex @option{-w} (@code{gnatchop}) Overwrite existing file names. Normally @code{gnatchop} regards it as a fatal error if there is already a file with the same name as a file it would otherwise output, in other words if the files to be @@ -12071,37 +11512,30 @@ chopped contain duplicated units. This switch bypasses this check, and causes all but the last instance of such duplicated units to be skipped. -@ifclear vms @item --GCC=@var{xxxx} @cindex @option{--GCC=} (@code{gnatchop}) Specify the path of the GNAT parser to be used. When this switch is used, no attempt is made to add the prefix to the GNAT parser executable. -@end ifclear @end table @node Examples of gnatchop Usage @section Examples of @code{gnatchop} Usage @table @code -@ifset vms -@item gnatchop /OVERWRITE HELLO_S.ADA [PRERELEASE.FILES] -@end ifset -@ifclear vms @item gnatchop -w hello_s.ada prerelease/files -@end ifclear Chops the source file @file{hello_s.ada}. The output files will be -placed in the directory @file{^prerelease/files^[PRERELEASE.FILES]^}, +placed in the directory @file{prerelease/files}, overwriting any files with matching names in that directory (no files in the current directory are modified). -@item gnatchop ^archive^ARCHIVE.^ -Chops the source file @file{^archive^ARCHIVE.^} +@item gnatchop archive +Chops the source file @file{archive} into the current directory. One useful application of @code{gnatchop} is in sending sets of sources around, for example in email messages. The required sources are simply -concatenated (for example, using a ^Unix @code{cat}^VMS @code{APPEND/NEW}^ +concatenated (for example, using a Unix @code{cat} command), and then @command{gnatchop} is used at the other end to reconstitute the original file names. @@ -12111,7 +11545,7 @@ 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 is generated, and no files are written. To override this check, use the -@option{^-w^/OVERWRITE^} switch, +@option{-w} switch, in which case the last occurrence in the last file will be the one that is output, and earlier duplicate occurrences for a given unit will be skipped. @@ -12257,43 +11691,38 @@ directory is searched for a file whose name is @file{gnat.adc}. If this file is present, it is expected to contain one or more configuration pragmas that will be applied to the current compilation. However, if the switch @option{-gnatA} is used, @file{gnat.adc} is not -considered. +considered. When taken into account, @file{gnat.adc} is added to the +dependencies, so that if @file{gnat.adc} is modified later, an invocation of +@command{gnatmake} will recompile the source. Configuration pragmas may be entered into the @file{gnat.adc} file either by running @code{gnatchop} on a source file that consists only of -configuration pragmas, or more conveniently by -direct editing of the @file{gnat.adc} file, which is a standard format -source file. +configuration pragmas, or more conveniently by direct editing of the +@file{gnat.adc} file, which is a standard format source file. In addition to @file{gnat.adc}, additional files containing configuration pragmas may be applied to the current compilation using the switch -@option{-gnatec}@var{path}. @var{path} must designate an existing file that +@option{-gnatec=}@var{path}. @var{path} must designate an existing file that contains only configuration pragmas. These configuration pragmas are in addition to those found in @file{gnat.adc} (provided @file{gnat.adc} is present and switch @option{-gnatA} is not used). -It is allowed to specify several switches @option{-gnatec}, all of which +It is allowable to specify several switches @option{-gnatec=}, all of which will be taken into account. +Files containing configuration pragmas specified with switches +@option{-gnatec=} are added to the dependencies, unless they are +temporary files. A file is considered temporary if its name ends in +@file{.tmp} or @file{.TMP}. Certain tools follow this naming +convention because they pass information to @command{gcc} via +temporary files that are immediately deleted; it doesn't make sense to +depend on a file that no longer exists. Such tools include +@command{gprbuild}, @command{gnatmake}, and @command{gnatcheck}. + If you are using project file, a separate mechanism is provided using project attributes, see @ref{Specifying Configuration Pragmas} for more details. -@ifset vms -Of special interest to GNAT OpenVMS Alpha is the following -configuration pragma: - -@smallexample @c ada -@cartouche -pragma Extend_System (Aux_DEC); -@end cartouche -@end smallexample - -@noindent -In the presence of this pragma, GNAT adds to the definition of the -predefined package SYSTEM all the additional types and subprograms that are -defined in HP Ada. See @ref{Compatibility with HP Ada} for details. -@end ifset @node Handling Arbitrary File Naming Conventions with gnatname @chapter Handling Arbitrary File Naming Conventions with @code{gnatname} @@ -12422,106 +11851,104 @@ Do not create a backup copy of an existing project file. @item --and Start another section of directories/patterns. -@item ^-c^/CONFIG_FILE=^@file{file} -@cindex @option{^-c^/CONFIG_FILE^} (@code{gnatname}) +@item -c@file{file} +@cindex @option{-c} (@code{gnatname}) Create a configuration pragmas file @file{file} (instead of the default @file{gnat.adc}). -@ifclear vms There may be zero, one or more space between @option{-c} and @file{file}. -@end ifclear @file{file} may include directory information. @file{file} must be -writable. There may be only one switch @option{^-c^/CONFIG_FILE^}. -When a switch @option{^-c^/CONFIG_FILE^} is -specified, no switch @option{^-P^/PROJECT_FILE^} may be specified (see below). +writable. There may be only one switch @option{-c}. +When a switch @option{-c} is +specified, no switch @option{-P} may be specified (see below). -@item ^-d^/SOURCE_DIRS=^@file{dir} -@cindex @option{^-d^/SOURCE_DIRS^} (@code{gnatname}) +@item -d@file{dir} +@cindex @option{-d} (@code{gnatname}) Look for source files in directory @file{dir}. There may be zero, one or more -spaces between @option{^-d^/SOURCE_DIRS=^} and @file{dir}. +spaces between @option{-d} and @file{dir}. @file{dir} may end with @code{/**}, that is it may be of the form @code{root_dir/**}. In this case, the directory @code{root_dir} and all of its subdirectories, recursively, have to be searched for sources. -When a switch @option{^-d^/SOURCE_DIRS^} +When a switch @option{-d} is specified, the current working directory will not be searched for source -files, unless it is explicitly specified with a @option{^-d^/SOURCE_DIRS^} -or @option{^-D^/DIR_FILES^} switch. -Several switches @option{^-d^/SOURCE_DIRS^} may be specified. +files, unless it is explicitly specified with a @option{-d} +or @option{-D} switch. +Several switches @option{-d} may be specified. If @file{dir} is a relative path, it is relative to the directory of the configuration pragmas file specified with switch -@option{^-c^/CONFIG_FILE^}, +@option{-c}, or to the directory of the project file specified with switch -@option{^-P^/PROJECT_FILE^} or, -if neither switch @option{^-c^/CONFIG_FILE^} -nor switch @option{^-P^/PROJECT_FILE^} are specified, it is relative to the +@option{-P} or, +if neither switch @option{-c} +nor switch @option{-P} are specified, it is relative to the current working directory. The directory -specified with switch @option{^-d^/SOURCE_DIRS^} must exist and be readable. +specified with switch @option{-d} must exist and be readable. -@item ^-D^/DIRS_FILE=^@file{file} -@cindex @option{^-D^/DIRS_FILE^} (@code{gnatname}) +@item -D@file{file} +@cindex @option{-D} (@code{gnatname}) Look for source files in all directories listed in text file @file{file}. -There may be zero, one or more spaces between @option{^-D^/DIRS_FILE=^} +There may be zero, one or more spaces between @option{-D} and @file{file}. @file{file} must be an existing, readable text file. Each nonempty line in @file{file} must be a directory. -Specifying switch @option{^-D^/DIRS_FILE^} is equivalent to specifying as many -switches @option{^-d^/SOURCE_DIRS^} as there are nonempty lines in +Specifying switch @option{-D} is equivalent to specifying as many +switches @option{-d} as there are nonempty lines in @file{file}. @item -eL Follow symbolic links when processing project files. -@item ^-f^/FOREIGN_PATTERN=^@file{pattern} -@cindex @option{^-f^/FOREIGN_PATTERN^} (@code{gnatname}) +@item -f@file{pattern} +@cindex @option{-f} (@code{gnatname}) Foreign patterns. Using this switch, it is possible to add sources of languages other than Ada to the list of sources of a project file. -It is only useful if a ^-P^/PROJECT_FILE^ switch is used. +It is only useful if a -P switch is used. For example, @smallexample -gnatname ^-Pprj -f"*.c"^/PROJECT_FILE=PRJ /FOREIGN_PATTERN=*.C^ "*.ada" +gnatname -Pprj -f"*.c" "*.ada" @end smallexample @noindent 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^C^}. +with extension @file{.c}. -@item ^-h^/HELP^ -@cindex @option{^-h^/HELP^} (@code{gnatname}) +@item -h +@cindex @option{-h} (@code{gnatname}) Output usage (help) information. The output is written to @file{stdout}. -@item ^-P^/PROJECT_FILE=^@file{proj} -@cindex @option{^-P^/PROJECT_FILE^} (@code{gnatname}) +@item -P@file{proj} +@cindex @option{-P} (@code{gnatname}) Create or update project file @file{proj}. There may be zero, one or more space between @option{-P} and @file{proj}. @file{proj} may include directory information. @file{proj} must be writable. -There may be only one switch @option{^-P^/PROJECT_FILE^}. -When a switch @option{^-P^/PROJECT_FILE^} is specified, -no switch @option{^-c^/CONFIG_FILE^} may be specified. +There may be only one switch @option{-P}. +When a switch @option{-P} is specified, +no switch @option{-c} may be specified. On all platforms, except on VMS, when @code{gnatname} is invoked for an existing project file .gpr, a backup copy of the project file is created in the project directory with file name .gpr.saved_x. 'x' is the first non negative number that makes this backup copy a new file. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@code{gnatname}) +@item -v +@cindex @option{-v} (@code{gnatname}) Verbose mode. Output detailed explanation of behavior to @file{stdout}. This includes name of the file written, the name of the directories to search and, for each file in those directories whose name matches at least one of the Naming Patterns, an indication of whether the file contains a unit, and if so the name of the unit. -@item ^-v -v^/VERBOSE /VERBOSE^ -@cindex @option{^-v -v^/VERBOSE /VERBOSE^} (@code{gnatname}) +@item -v -v +@cindex @option{-v -v} (@code{gnatname}) Very Verbose mode. In addition to the output produced in verbose mode, for each file in the searched directories whose name matches none of the Naming Patterns, an indication is given that there is no match. -@item ^-x^/EXCLUDED_PATTERN=^@file{pattern} -@cindex @option{^-x^/EXCLUDED_PATTERN^} (@code{gnatname}) +@item -x@file{pattern} +@cindex @option{-x} (@code{gnatname}) Excluded patterns. Using this switch, it is possible to exclude some files that would match the name patterns. For example, @smallexample -gnatname ^-x "*_nt.ada"^/EXCLUDED_PATTERN=*_nt.ada^ "*.ada" +gnatname -x "*_nt.ada" "*.ada" @end smallexample @noindent will look for Ada units in all files with the @file{.ada} extension, @@ -12532,44 +11959,27 @@ except those whose names end with @file{_nt.ada}. @node Examples of gnatname Usage @section Examples of @code{gnatname} Usage -@ifset vms -@smallexample -$ gnatname /CONFIG_FILE=[HOME.ME]NAMES.ADC /SOURCE_DIRS=SOURCES "[a-z]*.ada*" -@end smallexample -@end ifset -@ifclear vms @smallexample $ gnatname -c /home/me/names.adc -d sources "[a-z]*.ada*" @end smallexample -@end ifclear @noindent -In this example, the directory @file{^/home/me^[HOME.ME]^} must already exist +In this example, the directory @file{/home/me} must already exist and be writable. In addition, the directory -@file{^/home/me/sources^[HOME.ME.SOURCES]^} (specified by -@option{^-d sources^/SOURCE_DIRS=SOURCES^}) must exist and be readable. +@file{/home/me/sources} (specified by +@option{-d sources}) must exist and be readable. -@ifclear vms Note the optional spaces after @option{-c} and @option{-d}. -@end ifclear @smallexample -@ifclear vms $ gnatname -P/home/me/proj -x "*_nt_body.ada" -dsources -dsources/plus -Dcommon_dirs.txt "body_*" "spec_*" -@end ifclear -@ifset vms -$ gnatname /PROJECT_FILE=[HOME.ME]PROJ - /EXCLUDED_PATTERN=*_nt_body.ada - /SOURCE_DIRS=(SOURCES,[SOURCES.PLUS]) - /DIRS_FILE=COMMON_DIRS.TXT "body_*" "spec_*" -@end ifset @end smallexample -Note that several switches @option{^-d^/SOURCE_DIRS^} may be used, +Note that several switches @option{-d} may be used, even in conjunction with one or several switches -@option{^-D^/DIRS_FILE^}. Several Naming Patterns and one excluded pattern +@option{-D}. Several Naming Patterns and one excluded pattern are used in this example. @c ***************************************** @@ -12645,7 +12055,7 @@ are used in this example. @noindent This section covers several topics related to @command{gnatmake} and -project files: defining ^switches^switches^ for @command{gnatmake} +project files: defining switches for @command{gnatmake} and for the tools that it invokes; specifying configuration pragmas; the use of the @code{Main} attribute; building and rebuilding library project files. @@ -12668,79 +12078,67 @@ The following switches are used by GNAT tools that support project files: @table @option -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (any project-aware tool) +@item -P@var{project} +@cindex @option{-P} (any project-aware tool) Indicates the name of a project file. This project file will be parsed with -the verbosity indicated by @option{^-vP^MESSAGE_PROJECT_FILES=^@emph{x}}, +the verbosity indicated by @option{-vP@emph{x}}, if any, and using the external references indicated -by @option{^-X^/EXTERNAL_REFERENCE^} switches, if any. -@ifclear vms +by @option{-X} switches, if any. There may zero, one or more spaces between @option{-P} and @var{project}. -@end ifclear -There must be only one @option{^-P^/PROJECT_FILE^} switch on the command line. +There must be only one @option{-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 -@option{^-P^/PROJECT_FILE^}, -@option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} -or @option{^-X^/EXTERNAL_REFERENCE^} is not significant. +@option{-P}, +@option{-vP@emph{x}} +or @option{-X} is not significant. -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} -@cindex @option{^-X^/EXTERNAL_REFERENCE^} (any project-aware tool) +@item -X@var{name=value} +@cindex @option{-X} (any project-aware tool) Indicates that external variable @var{name} has the value @var{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. -@ifclear vms If @var{name} or @var{value} includes a space, then @var{name=value} should be put between quotes. @smallexample -XOS=NT -X"user=John Doe" @end smallexample -@end ifclear -Several @option{^-X^/EXTERNAL_REFERENCE^} switches can be used simultaneously. -If several @option{^-X^/EXTERNAL_REFERENCE^} switches specify the same +Several @option{-X} switches can be used simultaneously. +If several @option{-X} switches specify the same @var{name}, only the last one is used. -An external variable specified with a @option{^-X^/EXTERNAL_REFERENCE^} switch +An external variable specified with a @option{-X} switch takes precedence over the value of the same name in the environment. -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} -@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (any project-aware tool) +@item -vP@emph{x} +@cindex @option{-vP} (any project-aware tool) Indicates the verbosity of the parsing of GNAT project files. -@ifclear vms @option{-vP0} means Default; @option{-vP1} means Medium; @option{-vP2} means High. -@end ifclear -@ifset vms -There are three possible options for this qualifier: DEFAULT, MEDIUM and -HIGH. -@end ifset -The default is ^Default^DEFAULT^: no output for syntactically correct +The default is Default: no output for syntactically correct project files. -If several @option{^-vP^/MESSAGES_PROJECT_FILE=^@emph{x}} switches are present, +If several @option{-vP@emph{x}} switches are present, only the last one is used. -@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^ -@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (any project-aware tool) +@item -aP +@cindex @option{-aP} (any project-aware tool) Add directory at the beginning of the project search path, in order, after the current working directory. -@ifclear vms @item -eL @cindex @option{-eL} (any project-aware tool) Follow all symbolic links when processing project files. -@end ifclear -@item ^--subdirs^/SUBDIRS^= -@cindex @option{^--subdirs^/SUBDIRS^=} (gnatmake and gnatclean) +@item --subdirs= +@cindex @option{--subdirs=} (gnatmake and gnatclean) This switch is recognized by @command{gnatmake} and @command{gnatclean}. It indicate that the real directories (except the source directories) are the subdirectories of the directories specified in the project files. @@ -12756,32 +12154,28 @@ automatically. @c --------------------------------------------- @noindent -@ifset vms -It is not currently possible to specify VMS style qualifiers in the project -files; only Unix style ^switches^switches^ may be specified. -@end ifset For each of the packages @code{Builder}, @code{Compiler}, @code{Binder}, and -@code{Linker}, you can specify a @code{^Default_Switches^Default_Switches^} +@code{Linker}, you can specify a @code{Default_Switches} attribute, a @code{Switches} attribute, or both; -as their names imply, these ^switch^switch^-related -attributes affect the ^switches^switches^ that are used for each of these GNAT +as their names imply, these switch-related +attributes affect the switches that are used for each of these GNAT components when @command{gnatmake} is invoked. As will be explained below, these -component-specific ^switches^switches^ precede -the ^switches^switches^ provided on the @command{gnatmake} command line. +component-specific switches precede +the switches provided on the @command{gnatmake} command line. -The @code{^Default_Switches^Default_Switches^} attribute is an attribute +The @code{Default_Switches} attribute is an attribute indexed by language name (case insensitive) whose value is a string list. For example: @smallexample @c projectfile @group -package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnaty^-gnaty^", - "^-v^-v^"); -end Compiler; +@b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-gnaty", + "-v"); +@b{end} Compiler; @end group @end smallexample @@ -12792,12 +12186,12 @@ on the operating system) whose value is a string list. For example: @smallexample @c projectfile @group -package Builder is - for Switches ("main1.adb") - use ("^-O2^-O2^"); - for Switches ("main2.adb") - use ("^-g^-g^"); -end Builder; +@b{package} Builder @b{is} + @b{for} Switches ("main1.adb") + @b{use} ("-O2"); + @b{for} Switches ("main2.adb") + @b{use} ("-g"); +@b{end} Builder; @end group @end smallexample @@ -12809,35 +12203,35 @@ In each case just the file name without an explicit extension is acceptable. For each tool used in a program build (@command{gnatmake}, the compiler, the binder, and the linker), the corresponding package @dfn{contributes} a set of -^switches^switches^ for each file on which the tool is invoked, based on the -^switch^switch^-related attributes defined in the package. -In particular, the ^switches^switches^ +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 @var{f} comprise: @itemize @bullet @item the value of attribute @code{Switches (@var{f})}, if it is specified in the package for the given file, -@item otherwise, the value of @code{^Default_Switches^Default_Switches^ ("Ada")}, +@item otherwise, the value of @code{Default_Switches ("Ada")}, if it is specified in the package. @end itemize @noindent If neither of these attributes is defined in the package, then the package does -not contribute any ^switches^switches^ for the given file. +not contribute any switches for the given file. -When @command{gnatmake} is invoked on a file, the ^switches^switches^ comprise +When @command{gnatmake} is invoked on a file, the switches comprise two sets, in the following order: those contributed for the file by the @code{Builder} package; and the switches passed on the command line. When @command{gnatmake} invokes a tool (compiler, binder, linker) on a file, -the ^switches^switches^ passed to the tool comprise three sets, +the switches passed to the tool comprise three sets, in the following order: @enumerate @item -the applicable ^switches^switches^ contributed for the file +the applicable switches contributed for the file by the @code{Builder} package in the project file supplied on the command line; @item @@ -12848,9 +12242,9 @@ see below) corresponding to the tool; and the applicable switches passed on the command line. @end enumerate -The term @emph{applicable ^switches^switches^} reflects the fact that -@command{gnatmake} ^switches^switches^ may or may not be passed to individual -tools, depending on the individual ^switch^switch^. +The term @emph{applicable switches} reflects the fact that +@command{gnatmake} switches may or may not be passed to individual +tools, depending on the individual switch. @command{gnatmake} may invoke the compiler on source files from different projects. The Project Manager will use the appropriate project file to @@ -12861,50 +12255,50 @@ As an example, consider the following package in a project file: @smallexample @c projectfile @group -project Proj1 is - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-g^-g^"); - for Switches ("a.adb") - use ("^-O1^-O1^"); - for Switches ("b.adb") - use ("^-O2^-O2^", - "^-gnaty^-gnaty^"); - end Compiler; -end Proj1; +@b{project} Proj1 @b{is} + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-g"); + @b{for} Switches ("a.adb") + @b{use} ("-O1"); + @b{for} Switches ("b.adb") + @b{use} ("-O2", + "-gnaty"); + @b{end} Compiler; +@b{end} Proj1; @end group @end smallexample @noindent If @command{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^switch^ -@option{^-O1^-O1^}, -@file{b.adb} with ^switches^switches^ -@option{^-O2^-O2^} -and @option{^-gnaty^-gnaty^}, -and @file{c.adb} with @option{^-g^-g^}. - -The following example illustrates the ordering of the ^switches^switches^ +@file{a.adb} will be compiled with the switch +@option{-O1}, +@file{b.adb} with switches +@option{-O2} +and @option{-gnaty}, +and @file{c.adb} with @option{-g}. + +The following example illustrates the ordering of the switches contributed by different packages: @smallexample @c projectfile @group -project Proj2 is - package Builder is - for Switches ("main.adb") - use ("^-g^-g^", - "^-O1^-)1^", - "^-f^-f^"); - end Builder; +@b{project} Proj2 @b{is} + @b{package} Builder @b{is} + @b{for} Switches ("main.adb") + @b{use} ("-g", + "-O1", + "-f"); + @b{end} Builder; @end group @group - package Compiler is - for Switches ("main.adb") - use ("^-O2^-O2^"); - end Compiler; -end Proj2; + @b{package} Compiler @b{is} + @b{for} Switches ("main.adb") + @b{use} ("-O2"); + @b{end} Compiler; +@b{end} Proj2; @end group @end smallexample @@ -12912,32 +12306,32 @@ end Proj2; If you issue the command: @smallexample - gnatmake ^-Pproj2^/PROJECT_FILE=PROJ2^ -O0 main + gnatmake -Pproj2 -O0 main @end smallexample @noindent then the compiler will be invoked on @file{main.adb} with the following -sequence of ^switches^switches^ +sequence of switches @smallexample - ^-g -O1 -O2 -O0^-g -O1 -O2 -O0^ + -g -O1 -O2 -O0 @end smallexample @noindent -with the last @option{^-O^-O^} -^switch^switch^ having precedence over the earlier ones; -several other ^switches^switches^ -(such as @option{^-c^-c^}) are added implicitly. +with the last @option{-O} +switch having precedence over the earlier ones; +several other switches +(such as @option{-c}) are added implicitly. -The ^switches^switches^ -@option{^-g^-g^} -and @option{^-O1^-O1^} are contributed by package -@code{Builder}, @option{^-O2^-O2^} is contributed +The switches +@option{-g} +and @option{-O1} are contributed by package +@code{Builder}, @option{-O2} is contributed by the package @code{Compiler} -and @option{^-O0^-O0^} comes from the command line. +and @option{-O0} comes from the command line. -The @option{^-g^-g^} -^switch^switch^ will also be passed in the invocation of +The @option{-g} +switch will also be passed in the invocation of @command{Gnatlink.} A final example illustrates switch contributions from packages in different @@ -12945,68 +12339,68 @@ project files: @smallexample @c projectfile @group -project Proj3 is - for Source_Files use ("pack.ads", "pack.adb"); - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnata^-gnata^"); - end Compiler; -end Proj3; +@b{project} Proj3 @b{is} + @b{for} Source_Files @b{use} ("pack.ads", "pack.adb"); + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-gnata"); + @b{end} Compiler; +@b{end} Proj3; @end group @group -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^-s^", - "^-g^-g^"); - end Builder; -end Proj4; +@b{with} "Proj3"; +@b{project} Proj4 @b{is} + @b{for} Source_Files @b{use} ("foo_main.adb", "bar_main.adb"); + @b{package} Builder @b{is} + @b{for} Switches ("foo_main.adb") + @b{use} ("-s", + "-g"); + @b{end} Builder; +@b{end} Proj4; @end group @group --- Ada source file: -with Pack; -procedure Foo_Main is +--@i{ Ada source file:} +@b{with} Pack; +@b{procedure} Foo_Main @b{is} @dots{} -end Foo_Main; +@b{end} Foo_Main; @end group @end smallexample @noindent If the command is @smallexample -gnatmake ^-PProj4^/PROJECT_FILE=PROJ4^ foo_main.adb -cargs -gnato +gnatmake -PProj4 foo_main.adb -cargs -gnato @end smallexample @noindent -then the ^switches^switches^ passed to the compiler for @file{foo_main.adb} are -@option{^-g^-g^} (contributed by the package @code{Proj4.Builder}) and -@option{^-gnato^-gnato^} (passed on the command line). -When the imported package @code{Pack} is compiled, the ^switches^switches^ used -are @option{^-g^-g^} from @code{Proj4.Builder}, -@option{^-gnata^-gnata^} (contributed from package @code{Proj3.Compiler}, -and @option{^-gnato^-gnato^} from the command line. +then the switches passed to the compiler for @file{foo_main.adb} are +@option{-g} (contributed by the package @code{Proj4.Builder}) and +@option{-gnato} (passed on the command line). +When the imported package @code{Pack} is compiled, the switches used +are @option{-g} from @code{Proj4.Builder}, +@option{-gnata} (contributed from package @code{Proj3.Compiler}, +and @option{-gnato} from the command line. -When using @command{gnatmake} with project files, some ^switches^switches^ or +When using @command{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^switches^ found in a project file, the relative paths +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 @command{gnatmake} is invoked. -The ^switches^switches^ for which this occurs are: -^-I^-I^, -^-A^-A^, -^-L^-L^, -^-aO^-aO^, -^-aL^-aL^, -^-aI^-aI^, as well as all arguments that are not switches (arguments to -^switch^switch^ -^-o^-o^, object files specified in package @code{Linker} or after --largs on the command line). The exception to this rule is the ^switch^switch^ -^--RTS=^--RTS=^ for which a relative path argument is never converted. +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 @code{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. @c --------------------------------------------- @node Specifying Configuration Pragmas @@ -13045,22 +12439,22 @@ with one or several main subprograms, by specifying their source files on the command line. @smallexample - gnatmake ^-P^/PROJECT_FILE=^prj main1.adb main2.adb main3.adb + gnatmake -Pprj main1.adb main2.adb main3.adb @end smallexample @noindent Each of these needs to be a source file of the same project, except -when the switch ^-u^/UNIQUE^ is used. +when the switch -u is used. -When ^-u^/UNIQUE^ is not used, all the mains need to be sources of the +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 @code{Builder} of this common project, the "main project" is the one that is considered by @command{gnatmake}. -When ^-u^/UNIQUE^ is used, the specified source files may be in projects +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^switches^ found in package @code{Builder} of the +command line, the switches found in package @code{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. @@ -13072,7 +12466,7 @@ 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 @code{Main} attribute is defined in a project file as a non-empty -string list and the switch @option{^-u^/UNIQUE^} is not used on the command +string list and the switch @option{-u} is not used on the command line, then invoking @command{gnatmake} with this project file but without any main on the command line is equivalent to invoking @command{gnatmake} with all the file names in the @code{Main} attribute on the command line. @@ -13080,16 +12474,16 @@ the file names in the @code{Main} attribute on the command line. Example: @smallexample @c projectfile @group - project Prj is - for Main use ("main1.adb", "main2.adb", "main3.adb"); - end Prj; + @b{project} Prj @b{is} + @b{for} Main @b{use} ("main1.adb", "main2.adb", "main3.adb"); + @b{end} Prj; @end group @end smallexample @noindent -With this project file, @code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^"} +With this project file, @code{"gnatmake -Pprj"} is equivalent to -@code{"gnatmake ^-Pprj^/PROJECT_FILE=PRJ^ main1.adb main2.adb main3.adb"}. +@code{"gnatmake -Pprj main1.adb main2.adb main3.adb"}. When the project attribute @code{Main} is not specified, or is specified as an empty string list, or when the switch @option{-u} is used on the command @@ -13103,12 +12497,12 @@ main project file. When no main is specified on the command line and attribute @code{Main} exists and includes several mains, or when several mains are specified on the -command line, the default ^switches^switches^ in package @code{Builder} will -be used for all mains, even if there are specific ^switches^switches^ +command line, the default switches in package @code{Builder} will +be used for all mains, even if there are specific switches specified for one or several mains. -But the ^switches^switches^ from package @code{Binder} or @code{Linker} will be -the specific ^switches^switches^ for each main, if they are specified. +But the switches from package @code{Binder} or @code{Linker} will be +the specific switches for each main, if they are specified. @c --------------------------------------------- @node Library Project Files @@ -13120,15 +12514,15 @@ When @command{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^/ACTION=BIND^ and -^-l^/ACTION=LINK^ have special meanings. +When a library project file is specified, switches -b and +-l have special meanings. @itemize @bullet -@item ^-b^/ACTION=BIND^ is only allowed for stand-alone libraries. It indicates +@item -b is only allowed for stand-alone libraries. It indicates to @command{gnatmake} that @command{gnatbind} should be invoked for the library. -@item ^-l^/ACTION=LINK^ may be used for all library projects. It indicates +@item -l may be used for all library projects. It indicates to @command{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 @@ -13139,26 +12533,26 @@ When a library project file is specified, switches ^-b^/ACTION=BIND^ and @c --------------------------------------------- @noindent -A number of GNAT tools, other than @command{^gnatmake^gnatmake^} +A number of GNAT tools, other than @command{gnatmake} can benefit from project files: -(@command{^gnatbind^gnatbind^}, +(@command{gnatbind}, @ifclear FSFEDITION -@command{^gnatcheck^gnatcheck^}, +@command{gnatcheck}, @end ifclear -@command{^gnatclean^gnatclean^}, +@command{gnatclean}, @ifclear FSFEDITION -@command{^gnatelim^gnatelim^}, +@command{gnatelim}, @end ifclear -@command{^gnatfind^gnatfind^}, -@command{^gnatlink^gnatlink^}, -@command{^gnatls^gnatls^}, +@command{gnatfind}, +@command{gnatlink}, +@command{gnatls}, @ifclear FSFEDITION -@command{^gnatmetric^gnatmetric^}, -@command{^gnatpp^gnatpp^}, -@command{^gnatstub^gnatstub^}, +@command{gnatmetric}, +@command{gnatpp}, +@command{gnatstub}, @end ifclear -and @command{^gnatxref^gnatxref^}). However, none of these tools can be invoked -directly with a project file switch (@option{^-P^/PROJECT_FILE=^}). +and @command{gnatxref}). However, none of these tools can be invoked +directly with a project file switch (@option{-P}). They must be invoked through the @command{gnat} driver. The @command{gnat} driver is a wrapper that accepts a number of commands and @@ -13170,32 +12564,32 @@ On non-VMS platforms, the @command{gnat} driver accepts the following commands (case insensitive): @itemize @bullet -@item BIND to invoke @command{^gnatbind^gnatbind^} -@item CHOP to invoke @command{^gnatchop^gnatchop^} -@item CLEAN to invoke @command{^gnatclean^gnatclean^} +@item BIND to invoke @command{gnatbind} +@item CHOP to invoke @command{gnatchop} +@item CLEAN to invoke @command{gnatclean} @item COMP or COMPILE to invoke the compiler @ifclear FSFEDITION -@item ELIM to invoke @command{^gnatelim^gnatelim^} +@item ELIM to invoke @command{gnatelim} @end ifclear -@item FIND to invoke @command{^gnatfind^gnatfind^} -@item KR or KRUNCH to invoke @command{^gnatkr^gnatkr^} -@item LINK to invoke @command{^gnatlink^gnatlink^} -@item LS or LIST to invoke @command{^gnatls^gnatls^} -@item MAKE to invoke @command{^gnatmake^gnatmake^} -@item NAME to invoke @command{^gnatname^gnatname^} -@item PREP or PREPROCESS to invoke @command{^gnatprep^gnatprep^} +@item FIND to invoke @command{gnatfind} +@item KR or KRUNCH to invoke @command{gnatkr} +@item LINK to invoke @command{gnatlink} +@item LS or LIST to invoke @command{gnatls} +@item MAKE to invoke @command{gnatmake} +@item NAME to invoke @command{gnatname} +@item PREP or PREPROCESS to invoke @command{gnatprep} @ifclear FSFEDITION -@item PP or PRETTY to invoke @command{^gnatpp^gnatpp^} -@item METRIC to invoke @command{^gnatmetric^gnatmetric^} -@item STUB to invoke @command{^gnatstub^gnatstub^} +@item PP or PRETTY to invoke @command{gnatpp} +@item METRIC to invoke @command{gnatmetric} +@item STUB to invoke @command{gnatstub} @end ifclear -@item XREF to invoke @command{^gnatxref^gnatxref^} +@item XREF to invoke @command{gnatxref} @end itemize @noindent (note that the compiler is invoked using the command -@command{^gnatmake -f -u -c^gnatmake -f -u -c^}). +@command{gnatmake -f -u -c}). On non-VMS platforms, between @command{gnat} and the command, two special switches may be used: @@ -13238,176 +12632,174 @@ PP or PRETTY, STUB, @end ifclear and XREF, the project file related switches -(@option{^-P^/PROJECT_FILE^}, -@option{^-X^/EXTERNAL_REFERENCE^} and -@option{^-vP^/MESSAGES_PROJECT_FILE=^x}) may be used in addition to +(@option{-P}, +@option{-X} and +@option{-vPx}) may be used in addition to the switches of the invoking tool. @ifclear FSFEDITION When GNAT PP or GNAT PRETTY is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatpp^gnatpp^} with all +specified on the command line, it invokes @command{gnatpp} with all the immediate sources of the specified project file. @end ifclear @ifclear FSFEDITION When GNAT METRIC is used with a project file, but with no source -specified on the command line, it invokes @command{^gnatmetric^gnatmetric^} +specified on the command line, it invokes @command{gnatmetric} with all the immediate sources of the specified project file and with -@option{^-d^/DIRECTORY^} with the parameter pointing to the object directory +@option{-d} with the parameter pointing to the object directory of the project. @end ifclear @ifclear FSFEDITION 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^/ALL_PROJECTS^ is specified on the command line, then -the underlying tool (^gnatpp^gnatpp^ or -^gnatmetric^gnatmetric^) is invoked for all sources of all projects, +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. -@ifclear vms (-U stands for Universal or Union of the project files of the project tree) @end ifclear -@end ifclear For each of the following commands, there is optionally a corresponding package in the main project. @itemize @bullet -@item package @code{Binder} for command BIND (invoking @code{^gnatbind^gnatbind^}) +@item package @code{Binder} for command BIND (invoking @code{gnatbind}) @ifclear FSFEDITION @item package @code{Check} for command CHECK (invoking - @code{^gnatcheck^gnatcheck^}) + @code{gnatcheck}) @end ifclear @item package @code{Compiler} for command COMP or COMPILE (invoking the compiler) @item package @code{Cross_Reference} for command XREF (invoking - @code{^gnatxref^gnatxref^}) + @code{gnatxref}) @ifclear FSFEDITION @item package @code{Eliminate} for command ELIM (invoking - @code{^gnatelim^gnatelim^}) + @code{gnatelim}) @end ifclear -@item package @code{Finder} for command FIND (invoking @code{^gnatfind^gnatfind^}) +@item package @code{Finder} for command FIND (invoking @code{gnatfind}) -@item package @code{Gnatls} for command LS or LIST (invoking @code{^gnatls^gnatls^}) +@item package @code{Gnatls} for command LS or LIST (invoking @code{gnatls}) @ifclear FSFEDITION @item package @code{Gnatstub} for command STUB - (invoking @code{^gnatstub^gnatstub^}) + (invoking @code{gnatstub}) @end ifclear -@item package @code{Linker} for command LINK (invoking @code{^gnatlink^gnatlink^}) +@item package @code{Linker} for command LINK (invoking @code{gnatlink}) @ifclear FSFEDITION @item package @code{Check} for command CHECK - (invoking @code{^gnatcheck^gnatcheck^}) + (invoking @code{gnatcheck}) @end ifclear @ifclear FSFEDITION @item package @code{Metrics} for command METRIC - (invoking @code{^gnatmetric^gnatmetric^}) + (invoking @code{gnatmetric}) @end ifclear @ifclear FSFEDITION @item package @code{Pretty_Printer} for command PP or PRETTY - (invoking @code{^gnatpp^gnatpp^}) + (invoking @code{gnatpp}) @end ifclear @end itemize @noindent Package @code{Gnatls} has a unique attribute @code{Switches}, -a simple variable with a string list value. It contains ^switches^switches^ -for the invocation of @code{^gnatls^gnatls^}. +a simple variable with a string list value. It contains switches +for the invocation of @code{gnatls}. @smallexample @c projectfile @group -project Proj1 is - package gnatls is - for Switches - use ("^-a^-a^", - "^-v^-v^"); - end gnatls; -end Proj1; +@b{project} Proj1 @b{is} + @b{package} gnatls @b{is} + @b{for} Switches + @b{use} ("-a", + "-v"); + @b{end} gnatls; +@b{end} Proj1; @end group @end smallexample @noindent All other packages have two attribute @code{Switches} and -@code{^Default_Switches^Default_Switches^}. +@code{Default_Switches}. @code{Switches} is an indexed attribute, indexed by the -source file name, that has a string list value: the ^switches^switches^ to be +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. -@code{^Default_Switches^Default_Switches^} is an attribute, +@code{Default_Switches} is an attribute, indexed by the programming language that has a string list value. -@code{^Default_Switches^Default_Switches^ ("Ada")} contains the -^switches^switches^ for the invocation of the tool corresponding +@code{Default_Switches ("Ada")} contains the +switches for the invocation of the tool corresponding to the package, except if a specific @code{Switches} attribute is specified for the source file. @smallexample @c projectfile @group -project Proj is +@b{project} Proj @b{is} - for Source_Dirs use ("**"); + @b{for} Source_Dirs @b{use} ("**"); - package gnatls is - for Switches use - ("^-a^-a^", - "^-v^-v^"); - end gnatls; + @b{package} gnatls @b{is} + @b{for} Switches @b{use} + ("-a", + "-v"); + @b{end} gnatls; @end group @group - package Compiler is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-gnatv^-gnatv^", - "^-gnatwa^-gnatwa^"); - end Binder; + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-gnatv", + "-gnatwa"); + @b{end} Binder; @end group @group - package Binder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^", - "^-e^-e^"); - end Binder; + @b{package} Binder @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-C", + "-e"); + @b{end} Binder; @end group @group - package Linker is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-C^-C^"); - for Switches ("main.adb") - use ("^-C^-C^", - "^-v^-v^", - "^-v^-v^"); - end Linker; + @b{package} Linker @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-C"); + @b{for} Switches ("main.adb") + @b{use} ("-C", + "-v", + "-v"); + @b{end} Linker; @end group @group - package Finder is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^"); - end Finder; + @b{package} Finder @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-a", + "-f"); + @b{end} Finder; @end group @group - package Cross_Reference is - for ^Default_Switches^Default_Switches^ ("Ada") - use ("^-a^-a^", - "^-f^-f^", - "^-d^-d^", - "^-u^-u^"); - end Cross_Reference; -end Proj; + @b{package} Cross_Reference @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-a", + "-f", + "-d", + "-u"); + @b{end} Cross_Reference; +@b{end} Proj; @end group @end smallexample @@ -13415,24 +12807,24 @@ end Proj; With the above project file, commands such as @smallexample - ^gnat comp -Pproj main^GNAT COMP /PROJECT_FILE=PROJ MAIN^ - ^gnat ls -Pproj main^GNAT LIST /PROJECT_FILE=PROJ MAIN^ - ^gnat xref -Pproj main^GNAT XREF /PROJECT_FILE=PROJ MAIN^ - ^gnat bind -Pproj main.ali^GNAT BIND /PROJECT_FILE=PROJ MAIN.ALI^ - ^gnat link -Pproj main.ali^GNAT LINK /PROJECT_FILE=PROJ MAIN.ALI^ + gnat comp -Pproj main + gnat ls -Pproj main + gnat xref -Pproj main + gnat bind -Pproj main.ali + gnat link -Pproj main.ali @end smallexample @noindent will set up the environment properly and invoke the tool with the switches found in the package corresponding to the tool: -@code{^Default_Switches^Default_Switches^ ("Ada")} for all tools, +@code{Default_Switches ("Ada")} for all tools, except @code{Switches ("main.adb")} -for @code{^gnatlink^gnatlink^}. +for @code{gnatlink}. @ifclear FSFEDITION It is also possible to invoke some of the tools, -(@code{^gnatcheck^gnatcheck^}, -@code{^gnatmetric^gnatmetric^}, -and @code{^gnatpp^gnatpp^}) +(@code{gnatcheck}, +@code{gnatmetric}, +and @code{gnatpp}) on a set of project units thanks to the combination of the switches @option{-P}, @option{-U} and possibly the main unit when one is interested in its closure. For instance, @@ -13552,8 +12944,8 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-a^/ALL_FILES^ -@cindex @option{^-a^/ALL_FILES^} (@command{gnatxref}) +@item -a +@cindex @option{-a} (@command{gnatxref}) If this switch is present, @code{gnatfind} and @code{gnatxref} will parse the read-only files found in the library search path. Otherwise, these files will be ignored. This option can be used to protect Gnat sources or your own @@ -13592,19 +12984,19 @@ default, which means that only the new extension will be considered. Specifies the default location of the runtime library. Same meaning as the equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@item ^-d^/DERIVED_TYPES^ -@cindex @option{^-d^/DERIVED_TYPES^} (@command{gnatxref}) +@item -d +@cindex @option{-d} (@command{gnatxref}) If this switch is set @code{gnatxref} will output the parent type reference for each matching derived types. -@item ^-f^/FULL_PATHNAME^ -@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatxref}) +@item -f +@cindex @option{-f} (@command{gnatxref}) If this switch is set, the output file names will be preceded by their directory (if the file was found in the search path). If this switch is not set, the directory will not be printed. -@item ^-g^/IGNORE_LOCALS^ -@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatxref}) +@item -g +@cindex @option{-g} (@command{gnatxref}) If this switch is set, information is output only for library-level entities, ignoring local entities. The use of this switch may accelerate @code{gnatfind} and @code{gnatxref}. @@ -13625,28 +13017,26 @@ project file in the current directory. If a project file is either specified or found by the tools, then the content of the source directory and object directory lines are added as if they -had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} -and @samp{^-aO^OBJECT_SEARCH^}. -@item ^-u^/UNUSED^ +had been specified respectively by @samp{-aI} +and @samp{-aO}. +@item -u Output only unused symbols. This may be really useful if you give your main compilation unit on the command line, as @code{gnatxref} will then display every unused entity and 'with'ed package. -@ifclear vms @item -v Instead of producing the default output, @code{gnatxref} will generate a @file{tags} file that can be used by vi. For examples how to use this feature, see @ref{Examples of gnatxref Usage}. The tags file is output to the standard output, thus you will have to redirect it to a file. -@end ifclear @end table @noindent All these switches may be in any order on the command line, and may even appear after the file names. They need not be separated by spaces, thus -you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of -@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. +you can say @samp{gnatxref -ag} instead of +@samp{gnatxref -a -g}. @node Switches for gnatfind @section @code{gnatfind} Switches @@ -13729,8 +13119,8 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-a^/ALL_FILES^ -@cindex @option{^-a^/ALL_FILES^} (@command{gnatfind}) +@item -a +@cindex @option{-a} (@command{gnatfind}) If this switch is present, @code{gnatfind} and @code{gnatxref} will parse the read-only files found in the library search path. Otherwise, these files will be ignored. This option can be used to protect Gnat sources or your own @@ -13769,25 +13159,25 @@ default, which means that only the new extension will be considered. Specifies the default location of the runtime library. Same meaning as the equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@item ^-d^/DERIVED_TYPE_INFORMATION^ -@cindex @option{^-d^/DERIVED_TYPE_INFORMATION^} (@code{gnatfind}) +@item -d +@cindex @option{-d} (@code{gnatfind}) If this switch is set, then @code{gnatfind} will output the parent type reference for each matching derived types. -@item ^-e^/EXPRESSIONS^ -@cindex @option{^-e^/EXPRESSIONS^} (@command{gnatfind}) +@item -e +@cindex @option{-e} (@command{gnatfind}) By default, @code{gnatfind} accept the simple regular expression set for @samp{pattern}. If this switch is set, then the pattern will be considered as full Unix-style regular expression. -@item ^-f^/FULL_PATHNAME^ -@cindex @option{^-f^/FULL_PATHNAME^} (@command{gnatfind}) +@item -f +@cindex @option{-f} (@command{gnatfind}) If this switch is set, the output file names will be preceded by their directory (if the file was found in the search path). If this switch is not set, the directory will not be printed. -@item ^-g^/IGNORE_LOCALS^ -@cindex @option{^-g^/IGNORE_LOCALS^} (@command{gnatfind}) +@item -g +@cindex @option{-g} (@command{gnatfind}) If this switch is set, information is output only for library-level entities, ignoring local entities. The use of this switch may accelerate @code{gnatfind} and @code{gnatxref}. @@ -13804,24 +13194,24 @@ project file in the current directory. If a project file is either specified or found by the tools, then the content of the source directory and object directory lines are added as if they -had been specified respectively by @samp{^-aI^/SOURCE_SEARCH^} and -@samp{^-aO^/OBJECT_SEARCH^}. +had been specified respectively by @samp{-aI} and +@samp{-aO}. -@item ^-r^/REFERENCES^ -@cindex @option{^-r^/REFERENCES^} (@command{gnatfind}) +@item -r +@cindex @option{-r} (@command{gnatfind}) By default, @code{gnatfind} will output only the information about the declaration, body or type completion of the entities. If this switch is set, the @code{gnatfind} will locate every reference to the entities in the files specified on the command line (or in every file in the search path if no file is given on the command line). -@item ^-s^/PRINT_LINES^ -@cindex @option{^-s^/PRINT_LINES^} (@command{gnatfind}) +@item -s +@cindex @option{-s} (@command{gnatfind}) If this switch is set, then @code{gnatfind} will output the content of the Ada source file lines were the entity was found. -@item ^-t^/TYPE_HIERARCHY^ -@cindex @option{^-t^/TYPE_HIERARCHY^} (@command{gnatfind}) +@item -t +@cindex @option{-t} (@command{gnatfind}) If this switch is set, then @code{gnatfind} will output the type hierarchy for the specified type. It act like -d option but recursively from parent type to parent type. When this switch is set it is not possible to @@ -13832,8 +13222,8 @@ specify more than one file. @noindent All these switches may be in any order on the command line, and may even appear after the file names. They need not be separated by spaces, thus -you can say @samp{gnatxref ^-ag^/ALL_FILES/IGNORE_LOCALS^} instead of -@samp{gnatxref ^-a -g^/ALL_FILES /IGNORE_LOCALS^}. +you can say @samp{gnatxref -ag} instead of +@samp{gnatxref -a -g}. As stated previously, gnatfind will search in every directory in the search path. You can force it to look only in the current directory if @@ -13845,9 +13235,7 @@ you specify @code{*} at the end of the command line. @noindent Project files allow a programmer to specify how to compile its application, where to find sources, etc. These files are used -@ifclear vms primarily by GPS, but they can also be used -@end ifclear by the two tools @code{gnatxref} and @code{gnatfind}. @@ -13866,13 +13254,13 @@ account. @table @code @item src_dir=DIR -[default: @code{"^./^[]^"}] +[default: @code{"./"}] specifies a directory where to look for source files. Multiple @code{src_dir} lines can be specified and they will be searched in the order they are specified. @item obj_dir=DIR -[default: @code{"^./^[]^"}] +[default: @code{"./"}] specifies a directory where to look for object and library files. Multiple @code{obj_dir} lines can be specified, and they will be searched in the order they are specified @@ -13900,29 +13288,14 @@ switches given to @command{gnatlink}. specifies the name of the executable for the application. This variable can be referred to in the following lines by using the @samp{$@{main@}} notation. -@ifset vms -@item comp_cmd=COMMAND -[default: @code{"GNAT COMPILE /SEARCH=$@{src_dir@} /DEBUG /TRY_SEMANTICS"}] -@end ifset -@ifclear vms @item comp_cmd=COMMAND [default: @code{"gcc -c -I$@{src_dir@} -g -gnatq"}] -@end ifclear specifies the command used to compile a single file in the application. -@ifset vms -@item make_cmd=COMMAND -[default: @code{"GNAT MAKE $@{main@} -/SOURCE_SEARCH=$@{src_dir@} /OBJECT_SEARCH=$@{obj_dir@} -/DEBUG /TRY_SEMANTICS /COMPILER_QUALIFIERS $@{comp_opt@} -/BINDER_QUALIFIERS $@{bind_opt@} /LINKER_QUALIFIERS $@{link_opt@}"}] -@end ifset -@ifclear vms @item make_cmd=COMMAND [default: @code{"gnatmake $@{main@} -aI$@{src_dir@} -aO$@{obj_dir@} -g -gnatq -cargs $@{comp_opt@} -bargs $@{bind_opt@} -largs $@{link_opt@}"}] -@end ifclear specifies the command used to recompile the whole application. @item run_cmd=COMMAND @@ -13992,14 +13365,14 @@ item ::= elmt ? -- matches elmt or nothing @group elmt ::= nschar -- matches given character elmt ::= [nschar @{nschar@}] -- matches any character listed -elmt ::= [^^^ nschar @{nschar@}] -- matches any character not listed +elmt ::= [^ nschar @{nschar@}] -- matches any character not listed elmt ::= [char - char] -- matches chars in given range elmt ::= \ char -- matches given character elmt ::= . -- matches any single character elmt ::= ( regexp ) -- parens used for grouping char ::= any character, including special characters -nschar ::= any character except ()[].*+?^^^ +nschar ::= any character except ()[].*+?^ @end group @end smallexample @@ -14032,29 +13405,29 @@ For the following examples, we will consider the following units: @group @cartouche main.ads: -1: with Bar; -2: package Main is -3: procedure Foo (B : in Integer); +1: @b{with} Bar; +2: @b{package} Main @b{is} +3: @b{procedure} Foo (B : @b{in} Integer); 4: C : Integer; -5: private +5: @b{private} 6: D : Integer; -7: end Main; +7: @b{end} Main; main.adb: -1: package body Main is -2: procedure Foo (B : in Integer) is -3: begin +1: @b{package} @b{body} Main @b{is} +2: @b{procedure} Foo (B : @b{in} Integer) @b{is} +3: @b{begin} 4: C := B; 5: D := B; 6: Bar.Print (B); 7: Bar.Print (C); -8: end Foo; -9: end Main; +8: @b{end} Foo; +9: @b{end} Main; bar.ads: -1: package Bar is -2: procedure Print (B : Integer); -3: end bar; +1: @b{package} Bar @b{is} +2: @b{procedure} Print (B : Integer); +3: @b{end} bar; @end cartouche @end group @end smallexample @@ -14118,7 +13491,6 @@ of these. @end table -@ifclear vms @subsection Using gnatxref with vi @code{gnatxref} can generate a tags file output, which can be used @@ -14137,26 +13509,25 @@ are in the search path!). From @command{vi}, you can then use the command @samp{:tag @var{entity}} (replacing @var{entity} by whatever you are looking for), and vi will display a new file with the corresponding declaration of entity. -@end ifclear @node Examples of gnatfind Usage @section Examples of @code{gnatfind} Usage @table @code -@item gnatfind ^-f^/FULL_PATHNAME^ xyz:main.adb +@item gnatfind -f xyz:main.adb Find declarations for all entities xyz referenced at least once in main.adb. The references are search in every library file in the search path. -The directories will be printed as well (as the @samp{^-f^/FULL_PATHNAME^} +The directories will be printed as well (as the @samp{-f} switch is set) The output will look like: @smallexample -^directory/^[directory]^main.ads:106:14: xyz <= declaration -^directory/^[directory]^main.adb:24:10: xyz <= body -^directory/^[directory]^foo.ads:45:23: xyz <= declaration +directory/main.ads:106:14: xyz <= declaration +directory/main.adb:24:10: xyz <= body +directory/foo.ads:45:23: xyz <= declaration @end smallexample @noindent @@ -14164,18 +13535,18 @@ that is to say, one of the entities xyz found in main.adb is declared at line 12 of main.ads (and its body is in main.adb), and another one is declared at line 45 of foo.ads -@item gnatfind ^-fs^/FULL_PATHNAME/SOURCE_LINE^ xyz:main.adb +@item gnatfind -fs xyz:main.adb This is the same command as the previous one, instead @code{gnatfind} will display the content of the Ada source file lines. The output will look like: @smallexample -^directory/^[directory]^main.ads:106:14: xyz <= declaration +directory/main.ads:106:14: xyz <= declaration procedure xyz; -^directory/^[directory]^main.adb:24:10: xyz <= body +directory/main.adb:24:10: xyz <= body procedure xyz is -^directory/^[directory]^foo.ads:45:23: xyz <= declaration +directory/foo.ads:45:23: xyz <= declaration xyz : Integer; @end smallexample @@ -14183,7 +13554,7 @@ The output will look like: This can make it easier to find exactly the location your are looking for. -@item gnatfind ^-r^/REFERENCES^ "*x*":main.ads:123 foo.adb +@item gnatfind -r "*x*":main.ads:123 foo.adb Find references to all entities containing an x that are referenced on line 123 of main.ads. The references will be searched only in main.ads and foo.adb. @@ -14194,7 +13565,7 @@ line 123 of main.ads. This is the same as @code{gnatfind "*":main.adb:123}. -@item gnatfind ^mydir/^[mydir]^main.adb:123:45 +@item gnatfind mydir/main.adb:123:45 Find the declaration for the entity referenced at column 45 in line 123 of file main.adb in directory mydir. Note that it is usual to omit the identifier name when the column is given, @@ -14218,7 +13589,7 @@ point to any character in the middle of the identifier. @end menu @noindent -^The @command{gnatpp} tool^GNAT PRETTY^ is an ASIS-based utility +The @command{gnatpp} tool is an ASIS-based utility for source reformatting / pretty-printing. It takes an Ada source file as input and generates a reformatted version as output. @@ -14270,7 +13641,7 @@ follow the GNAT file naming rules @samp{@var{gcc_switches}} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatpp} to generate the ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +@option{-I} switches to form the source search path, use the @option{-gnatec} switch to set the configuration file, etc. @end itemize @@ -14281,7 +13652,6 @@ use the @option{-gnatec} switch to set the configuration file, etc. The following subsections describe the various switches accepted by @command{gnatpp}, organized by category. -@ifclear vms You specify a switch by supplying a name and generally also a value. In many cases the values for a switch with a given name are incompatible with each other @@ -14295,16 +13665,7 @@ You may supply several such switches to @command{gnatpp}, but then each must be specified in full, with both the name and the value. Abbreviated forms (the name appearing once, followed by each value) are not permitted. -@end ifclear -@ifset vms -In many cases the set of options for a given qualifier are incompatible with -each other (for example the qualifier that controls the casing of a reserved -word may have exactly one option, which specifies either upper case, lower -case, or mixed case), and thus exactly one such option can be in effect for -an invocation of @command{gnatpp}. -If more than one is supplied, the last one is used. -@end ifset @menu * Alignment Control:: @@ -14329,12 +13690,12 @@ By default alignment of the following constructs is set ON: representation clauses. @table @option -@cindex @option{^-A@var{n}^/ALIGN^} (@command{gnatpp}) +@cindex @option{-A@var{n}} (@command{gnatpp}) -@item ^-A0^/ALIGN=OFF^ +@item -A0 Set alignment to OFF -@item ^-A1^/ALIGN=ON^ +@item -A1 Set alignment to ON @end table @@ -14355,115 +13716,115 @@ following an underscore, are converted to their uppercase forms; all the other letters are converted to their lowercase forms. @table @option -@cindex @option{^-a@var{x}^/ATTRIBUTE^} (@command{gnatpp}) -@item ^-aL^/ATTRIBUTE_CASING=LOWER_CASE^ +@cindex @option{-a@var{x}} (@command{gnatpp}) +@item -aL Attribute designators are lower case -@item ^-aU^/ATTRIBUTE_CASING=UPPER_CASE^ +@item -aU Attribute designators are upper case -@item ^-aM^/ATTRIBUTE_CASING=MIXED_CASE^ +@item -aM Attribute designators are mixed case (this is the default) -@cindex @option{^-k@var{x}^/KEYWORD_CASING^} (@command{gnatpp}) -@item ^-kL^/KEYWORD_CASING=LOWER_CASE^ +@cindex @option{-k@var{x}} (@command{gnatpp}) +@item -kL Keywords (technically, these are known in Ada as @emph{reserved words}) are lower case (this is the default) -@item ^-kU^/KEYWORD_CASING=UPPER_CASE^ +@item -kU Keywords are upper case -@cindex @option{^-n@var{x}^/NAME_CASING^} (@command{gnatpp}) -@item ^-nD^/NAME_CASING=AS_DECLARED^ +@cindex @option{-n@var{x}} (@command{gnatpp}) +@item -nD Name casing for defining occurrences are as they appear in the source file (this is the default) -@item ^-nU^/NAME_CASING=UPPER_CASE^ +@item -nU Names are in upper case -@item ^-nL^/NAME_CASING=LOWER_CASE^ +@item -nL Names are in lower case -@item ^-nM^/NAME_CASING=MIXED_CASE^ +@item -nM Names are in mixed case -@cindex @option{^-ne@var{x}^/ENUM_CASING^} (@command{gnatpp}) -@item ^-neD^/ENUM_CASING=AS_DECLARED^ +@cindex @option{-ne@var{x}} (@command{gnatpp}) +@item -neD Enumeration literal casing for defining occurrences are as they appear in the -source file. Overrides ^-n^/NAME_CASING^ casing setting. +source file. Overrides -n casing setting. -@item ^-neU^/ENUM_CASING=UPPER_CASE^ -Enumeration literals are in upper case. Overrides ^-n^/NAME_CASING^ casing +@item -neU +Enumeration literals are in upper case. Overrides -n casing setting. -@item ^-neL^/ENUM_CASING=LOWER_CASE^ -Enumeration literals are in lower case. Overrides ^-n^/NAME_CASING^ casing +@item -neL +Enumeration literals are in lower case. Overrides -n casing setting. -@item ^-neM^/ENUM_CASING=MIXED_CASE^ -Enumeration literals are in mixed case. Overrides ^-n^/NAME_CASING^ casing +@item -neM +Enumeration literals are in mixed case. Overrides -n casing setting. -@cindex @option{^-nt@var{x}^/TYPE_CASING^} (@command{gnatpp}) -@item ^-neD^/TYPE_CASING=AS_DECLARED^ +@cindex @option{-nt@var{x}} (@command{gnatpp}) +@item -neD Names introduced by type and subtype declarations are always cased as they appear in the declaration in the source file. -Overrides ^-n^/NAME_CASING^ casing setting. +Overrides -n casing setting. -@item ^-ntU^/TYPE_CASING=UPPER_CASE^ +@item -ntU Names introduced by type and subtype declarations are always in -upper case. Overrides ^-n^/NAME_CASING^ casing setting. +upper case. Overrides -n casing setting. -@item ^-ntL^/TYPE_CASING=LOWER_CASE^ +@item -ntL Names introduced by type and subtype declarations are always in -lower case. Overrides ^-n^/NAME_CASING^ casing setting. +lower case. Overrides -n casing setting. -@item ^-ntM^/TYPE_CASING=MIXED_CASE^ +@item -ntM Names introduced by type and subtype declarations are always in -mixed case. Overrides ^-n^/NAME_CASING^ casing setting. +mixed case. Overrides -n casing setting. -@item ^-nnU^/NUMBER_CASING=UPPER_CASE^ +@item -nnU Names introduced by number declarations are always in -upper case. Overrides ^-n^/NAME_CASING^ casing setting. +upper case. Overrides -n casing setting. -@item ^-nnL^/NUMBER_CASING=LOWER_CASE^ +@item -nnL Names introduced by number declarations are always in -lower case. Overrides ^-n^/NAME_CASING^ casing setting. +lower case. Overrides -n casing setting. -@item ^-nnM^/NUMBER_CASING=MIXED_CASE^ +@item -nnM Names introduced by number declarations are always in -mixed case. Overrides ^-n^/NAME_CASING^ casing setting. +mixed case. Overrides -n casing setting. -@cindex @option{^-p@var{x}^/PRAGMA_CASING^} (@command{gnatpp}) -@item ^-pL^/PRAGMA_CASING=LOWER_CASE^ +@cindex @option{-p@var{x}} (@command{gnatpp}) +@item -pL Pragma names are lower case -@item ^-pU^/PRAGMA_CASING=UPPER_CASE^ +@item -pU Pragma names are upper case -@item ^-pM^/PRAGMA_CASING=MIXED_CASE^ +@item -pM Pragma names are mixed case (this is the default) -@item ^-D@var{file}^/DICTIONARY=@var{file}^ -@cindex @option{^-D^/DICTIONARY^} (@command{gnatpp}) +@item -D@var{file} +@cindex @option{-D} (@command{gnatpp}) Use @var{file} as a @emph{dictionary file} that defines the casing for a set of specified names, thereby overriding the effect on these names by any explicit or implicit -^-n^/NAME_CASING^ switch. +-n switch. To supply more than one dictionary file, -use ^several @option{-D} switches^a list of files as options^. +use several @option{-D} switches. @noindent @option{gnatpp} implicitly uses a @emph{default dictionary file} to define the casing for the Ada predefined names and the names declared in the GNAT libraries. -@item ^-D-^/SPECIFIC_CASING^ -@cindex @option{^-D-^/SPECIFIC_CASING^} (@command{gnatpp}) +@item -D- +@cindex @option{-D-} (@command{gnatpp}) Do not use the default dictionary file; instead, use the casing -defined by a @option{^-n^/NAME_CASING^} switch and any explicit +defined by a @option{-n} switch and any explicit dictionary file(s) @end table @@ -14471,8 +13832,8 @@ dictionary file(s) The structure of a dictionary file, and details on the conventions used in the default dictionary file, are defined in @ref{Name Casing}. -The @option{^-D-^/SPECIFIC_CASING^} and -@option{^-D@var{file}^/DICTIONARY=@var{file}^} switches are mutually +The @option{-D-} and +@option{-D@var{file}} switches are mutually compatible. @noindent @@ -14481,21 +13842,21 @@ complex syntactic constructs. See @ref{Formatting Comments} for details on their effect. @table @option -@cindex @option{^-c@var{n}^/COMMENTS_LAYOUT^} (@command{gnatpp}) -@item ^-c0^/COMMENTS_LAYOUT=UNTOUCHED^ +@cindex @option{-c@var{n}} (@command{gnatpp}) +@item -c0 All comments remain unchanged. -@item ^-c1^/COMMENTS_LAYOUT=DEFAULT^ +@item -c1 GNAT-style comment line indentation. This is the default. -@item ^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^ +@item -c3 GNAT-style comment beginning. -@item ^-c4^/COMMENTS_LAYOUT=REFORMAT^ +@item -c4 Fill comment blocks. -@item ^-c5^/COMMENTS_LAYOUT=KEEP_SPECIAL^ +@item -c5 Keep unchanged special form comments. This is the default. @@ -14503,51 +13864,43 @@ This is the default. @cindex @option{--comments-only} @command{gnatpp} Format just the comments. -@cindex @option{^--no-separate-is^/NO_SEPARATE_IS^} (@command{gnatpp}) -@item ^--no-separate-is^/NO_SEPARATE_IS^ +@cindex @option{--no-separate-is} (@command{gnatpp}) +@item --no-separate-is Do not place the keyword @code{is} on a separate line in a subprogram body in case if the spec occupies more than one line. -@cindex @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} (@command{gnatpp}) -@item ^--separate-loop-then^/SEPARATE_LOOP_THEN^ +@cindex @option{--separate-loop-then} (@command{gnatpp}) +@item --separate-loop-then Place the keyword @code{loop} in FOR and WHILE loop statements and the keyword @code{then} in IF statements on a separate line. -@cindex @option{^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^} (@command{gnatpp}) -@item ^--no-separate-loop-then^/NO_SEPARATE_LOOP_THEN^ +@cindex @option{--no-separate-loop-then} (@command{gnatpp}) +@item --no-separate-loop-then Do not place the keyword @code{loop} in FOR and WHILE loop statements and the keyword @code{then} in IF statements on a separate line. This option is -incompatible with @option{^--separate-loop-then^/SEPARATE_LOOP_THEN^} option. +incompatible with @option{--separate-loop-then} option. -@cindex @option{^--use-on-new-line^/USE_ON_NEW_LINE^} (@command{gnatpp}) -@item ^--use-on-new-line^/USE_ON_NEW_LINE^ +@cindex @option{--use-on-new-line} (@command{gnatpp}) +@item --use-on-new-line Start each USE clause in a context clause from a separate line. -@cindex @option{^--insert-blank-lines^/INSERT_BLANK_LINES^} (@command{gnatpp}) -@item ^--insert-blank-lines^/INSERT_BLANK_LINES^ +@cindex @option{--insert-blank-lines} (@command{gnatpp}) +@item --insert-blank-lines Insert blank lines where appropriate (between bodies and other large constructs). -@cindex @option{^--preserve-blank-lines^/PRESERVE_BLANK_LINES^} (@command{gnatpp}) -@item ^--preserve-blank-lines^/PRESERVE_BLANK_LINES^ +@cindex @option{--preserve-blank-lines} (@command{gnatpp}) +@item --preserve-blank-lines Preserve blank lines in the input. By default, gnatpp will squeeze multiple blank lines down to one. @end table -@ifclear vms @noindent The @option{-c} switches are compatible with one another, except that the @option{-c0} switch disables all other comment formatting switches. -@end ifclear -@ifset vms -@noindent -For the @option{/COMMENTS_LAYOUT} qualifier, -The @option{GNAT_BEGINNING}, @option{REFORMAT}, and @option{DEFAULT} -options are compatible with one another. -@end ifset @node General Text Layout Control @subsection General Text Layout Control @@ -14556,16 +13909,16 @@ options are compatible with one another. These switches allow control over line length and indentation. @table @option -@item ^-M@var{nnn}^/LINE_LENGTH_MAX=@var{nnn}^ -@cindex @option{^-M^/LINE_LENGTH^} (@command{gnatpp}) +@item -M@var{nnn} +@cindex @option{-M} (@command{gnatpp}) Maximum line length, @var{nnn} from 32@dots{}256, the default value is 79 -@item ^-i@var{nnn}^/INDENTATION_LEVEL=@var{nnn}^ -@cindex @option{^-i^/INDENTATION_LEVEL^} (@command{gnatpp}) +@item -i@var{nnn} +@cindex @option{-i} (@command{gnatpp}) Indentation level, @var{nnn} from 1@dots{}9, the default value is 3 -@item ^-cl@var{nnn}^/CONTINUATION_INDENT=@var{nnn}^ -@cindex @option{^-cl^/CONTINUATION_INDENT^} (@command{gnatpp}) +@item -cl@var{nnn} +@cindex @option{-cl} (@command{gnatpp}) Indentation level for continuation lines (relative to the line being continued), @var{nnn} from 1@dots{}9. The default @@ -14595,24 +13948,24 @@ Same as @code{--decimal-grouping}, but for based literals. For example, with @code{--based-grouping=4}, @code{16#0001FFFE#} will be changed to @code{16#0001_FFFE#}. -@item ^--RM-style-spacing^/RM_STYLE_SPACING^ -@cindex @option{^--RM-style-spacing^/RM_STYLE_SPACING^} (@command{gnatpp}) +@item --RM-style-spacing +@cindex @option{--RM-style-spacing} (@command{gnatpp}) Do not insert an extra blank before various occurrences of `(' and `:'. This also turns off alignment. -@item ^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^ -@cindex @option{^-ff^/FORM_FEED_AFTER_PRAGMA_PAGE^} (@command{gnatpp}) +@item -ff +@cindex @option{-ff} (@command{gnatpp}) Insert a Form Feed character after a pragma Page. -@item ^--call_threshold=@var{nnn}^/MAX_ACT=@var{nnn}^ -@cindex @option{^--call_threshold^/MAX_ACT^} (@command{gnatpp}) +@item --call_threshold=@var{nnn} +@cindex @option{--call_threshold} (@command{gnatpp}) If the number of parameter associations is greater than @var{nnn} and if at least one association uses named notation, start each association from a new line. If @var{nnn} is 0, no check for the number of associations is made; this is the default. -@item ^--par_threshold=@var{nnn}^/MAX_PAR=@var{nnn}^ -@cindex @option{^--par_threshold^/MAX_PAR^} (@command{gnatpp}) +@item --par_threshold=@var{nnn} +@cindex @option{--par_threshold} (@command{gnatpp}) If the number of parameter specifications is greater than @var{nnn} (or equal to @var{nnn} in case of a function), start each specification from a new line. This feature is disabled by default. @@ -14626,17 +13979,17 @@ To define the search path for the input source file, @command{gnatpp} uses the same switches as the GNAT compiler, with the same effects: @table @option -@item ^-I^/SEARCH=^@var{dir} -@cindex @option{^-I^/SEARCH^} (@command{gnatpp}) +@item -I@var{dir} +@cindex @option{-I} (@command{gnatpp}) -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@command{gnatpp}) +@item -I- +@cindex @option{-I-} (@command{gnatpp}) -@item ^-gnatec^/CONFIGURATION_PRAGMAS_FILE^=@var{path} -@cindex @option{^-gnatec^/CONFIGURATION_PRAGMAS_FILE^} (@command{gnatpp}) +@item -gnatec=@var{path} +@cindex @option{-gnatec} (@command{gnatpp}) -@item ^--RTS^/RUNTIME_SYSTEM^=@var{path} -@cindex @option{^--RTS^/RUNTIME_SYSTEM^} (@command{gnatpp}) +@item --RTS=@var{path} +@cindex @option{--RTS} (@command{gnatpp}) @end table @@ -14645,105 +13998,105 @@ uses the same switches as the GNAT compiler, with the same effects: @noindent By default the output is sent to a file whose name is obtained by appending -the ^@file{.pp}^@file{$PP}^ suffix to the name of the input file. +the @file{.pp} suffix to the name of the input file. If the file with this name already exists, it is overwritten. -Thus if the input file is @file{^my_ada_proc.adb^MY_ADA_PROC.ADB^} then -@command{gnatpp} will produce @file{^my_ada_proc.adb.pp^MY_ADA_PROC.ADB$PP^} +Thus if the input file is @file{my_ada_proc.adb} then +@command{gnatpp} will produce @file{my_ada_proc.adb.pp} as output file. The output may be redirected by the following switches: @table @option -@item ^--output-dir=@var{dir}^/OUTPUT_DIR=@var{dir}^ -@cindex @option{^--output-dir^/OUTPUT_DIR^} (@command{gnatpp}) +@item --output-dir=@var{dir} +@cindex @option{--output-dir} (@command{gnatpp}) Generate output file in directory @file{dir} with the same name as the input file. If @file{dir} is the same as the directory containing the input file, -the input file is not processed; use @option{^-rnb^/REPLACE_NO_BACKUP^} +the input file is not processed; use @option{-rnb} if you want to update the input file in place. -@item ^-pipe^/STANDARD_OUTPUT^ -@cindex @option{^-pipe^/STANDARD_OUTPUT^} (@command{gnatpp}) +@item -pipe +@cindex @option{-pipe} (@command{gnatpp}) Send the output to @code{Standard_Output} -@item ^-o @var{output_file}^/OUTPUT=@var{output_file}^ -@cindex @option{^-o^/OUTPUT^} (@code{gnatpp}) +@item -o @var{output_file} +@cindex @option{-o} (@code{gnatpp}) Write the output into @var{output_file}. If @var{output_file} already exists, @command{gnatpp} terminates without reading or processing the input file. -@item ^-of ^/FORCED_OUTPUT=^@var{output_file} -@cindex @option{^-of^/FORCED_OUTPUT^} (@command{gnatpp}) +@item -of @var{output_file} +@cindex @option{-of} (@command{gnatpp}) Write the output into @var{output_file}, overwriting the existing file (if one is present). -@item ^-r^/REPLACE^ -@cindex @option{^-r^/REPLACE^} (@command{gnatpp}) +@item -r +@cindex @option{-r} (@command{gnatpp}) Replace the input source file with the reformatted output, and copy the original input source into the file whose name is obtained by appending the -^@file{.npp}^@file{$NPP}^ suffix to the name of the input file. +@file{.npp} suffix to the name of the input file. If a file with this name already exists, @command{gnatpp} terminates without reading or processing the input file. -@item ^-rf^/OVERRIDING_REPLACE^ -@cindex @option{^-rf^/OVERRIDING_REPLACE^} (@code{gnatpp}) -Like @option{^-r^/REPLACE^} except that if the file with the specified name +@item -rf +@cindex @option{-rf} (@code{gnatpp}) +Like @option{-r} except that if the file with the specified name already exists, it is overwritten. -@item ^-rnb^/REPLACE_NO_BACKUP^ -@cindex @option{^-rnb^/REPLACE_NO_BACKUP^} (@command{gnatpp}) +@item -rnb +@cindex @option{-rnb} (@command{gnatpp}) Replace the input source file with the reformatted output without creating any backup copy of the input source. -@item ^--eol=@var{xxx}^/END_OF_LINE=@var{xxx}^ -@cindex @option{^--eol^/END_OF_LINE^} (@code{gnatpp}) +@item --eol=@var{xxx} +@cindex @option{--eol} (@code{gnatpp}) Specifies the line-ending style of the reformatted output file. The @var{xxx} -^string specified with the switch^option^ may be: +string specified with the switch may be: @itemize @bullet -@item ``@option{^dos^DOS^}'' MS DOS style, lines end with CR LF characters -@item ``@option{^crlf^CRLF^}'' -the same as @option{^dos^DOS^} -@item ``@option{^unix^UNIX^}'' UNIX style, lines end with LF character -@item ``@option{^lf^LF^}'' -the same as @option{^unix^UNIX^} +@item ``@option{dos}'' MS DOS style, lines end with CR LF characters +@item ``@option{crlf}'' +the same as @option{dos} +@item ``@option{unix}'' UNIX style, lines end with LF character +@item ``@option{lf}'' +the same as @option{unix} @end itemize -@item ^-W^/RESULT_ENCODING=^@var{e} -@cindex @option{^-W^/RESULT_ENCODING=^} (@command{gnatpp}) +@item -W@var{e} +@cindex @option{-W} (@command{gnatpp}) Specify the wide character encoding method for the input and output files. @var{e} is one of the following: @itemize @bullet -@item ^h^HEX^ +@item h Hex encoding -@item ^u^UPPER^ +@item u Upper half encoding -@item ^s^SHIFT_JIS^ +@item s Shift/JIS encoding -@item ^e^EUC^ +@item e EUC encoding -@item ^8^UTF8^ +@item 8 UTF-8 encoding -@item ^b^BRACKETS^ +@item b Brackets encoding (default value) @end itemize @end table @noindent -Options @option{^-o^/OUTPUT^} and -@option{^-of^/FORCED_OUTPUT^} are allowed only if the call to gnatpp +Options @option{-o} and +@option{-of} are allowed only if the call to gnatpp contains only one file to reformat. Option -@option{^--eol^/END_OF_LINE^} +@option{--eol} and -@option{^-W^/RESULT_ENCODING^} +@option{-W} cannot be used together -with @option{^-pipe^/STANDARD_OUTPUT^} option. +with @option{-pipe} option. @node Other gnatpp Switches @subsection Other @code{gnatpp} Switches @@ -14790,7 +14143,9 @@ tool argument. Incremental processing on a per-file basis. Source files are only processed if they have been modified, or if files they depend on have been modified. This is similar to the way gnatmake/gprbuild only -compiles files that need to be recompiled. +compiles files that need to be recompiled. A project file is required +in this mode, and the gnat driver (as in @command{gnat pretty}) is not +supported. @item --pp-off=@var{xxx} @cindex @option{--pp-off} @command{gnatpp} @@ -14806,41 +14161,41 @@ of the default @code{--!pp on}. @cindex @option{--pp-old} @command{gnatpp} Use the old formatting algorithms. -@item ^-files @var{filename}^/FILES=@var{filename}^ -@cindex @option{^-files^/FILES^} (@code{gnatpp}) +@item -files @var{filename} +@cindex @option{-files} (@code{gnatpp}) Take the argument source files from the specified file. This file should be an ordinary text file containing file names separated by spaces or line breaks. You can use this switch more than once in the same call to @command{gnatpp}. You also can combine this switch with an explicit list of files. -@item ^-j^/PROCESSES=^@var{n} -@cindex @option{^-j^/PROCESSES^} (@command{gnatpp}) +@item -j@var{n} +@cindex @option{-j} (@command{gnatpp}) Without @option{--incremental}, use @var{n} processes to carry out the tree creations (internal representations of the argument sources). On a multiprocessor machine this speeds up processing of big sets of argument sources. If @var{n} is 0, then the maximum number of parallel tree creations is the number of core processors on the platform. This -option cannot be used together with @option{^-r^/REPLACE^}, -@option{^-rf^/OVERRIDING_REPLACE^} or -@option{^-rnb^/REPLACE_NO_BACKUP^} option. +option cannot be used together with @option{-r}, +@option{-rf} or +@option{-rnb} option. With @option{--incremental}, use @var{n} @command{gnatpp} processes to perform pretty-printing in parallel. @var{n} = 0 means the same as -above. In this case, @option{^-r^/REPLACE^}, -@option{^-rf^/OVERRIDING_REPLACE^} or -@option{^-rnb^/REPLACE_NO_BACKUP^} options are allowed. +above. In this case, @option{-r}, +@option{-rf} or +@option{-rnb} options are allowed. -@cindex @option{^-t^/TIME^} (@command{gnatpp}) -@item ^-t^/TIME^ +@cindex @option{-t} (@command{gnatpp}) +@item -t Print out execution time. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@command{gnatpp}) +@item -v +@cindex @option{-v} (@command{gnatpp}) Verbose mode -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@command{gnatpp}) +@item -q +@cindex @option{-q} (@command{gnatpp}) Quiet mode @end table @@ -14887,13 +14242,13 @@ be followed by arbitrary additional text. For example: @smallexample @c ada @cartouche -package Interrupts is - --!pp off -- turn off pretty printing so "Interrupt_Kind" lines up - type Interrupt_Kind is +@b{package} Interrupts @b{is} + --@i{!pp off -- turn off pretty printing so "Interrupt_Kind" lines up} + @b{type} Interrupt_Kind @b{is} (Asynchronous_Interrupt_Kind, Synchronous_Interrupt_Kind, Green_Interrupt_Kind); - --!pp on -- reenable pretty printing + --@i{!pp on -- reenable pretty printing} ... @end cartouche @@ -14918,10 +14273,10 @@ The output file will contain no lines with trailing white space. By default, a sequence of one or more blank lines in the input is converted to a single blank line in the output; multiple blank lines are squeezed down to one. -The @option{^--preserve-blank-lines^/PRESERVE_BLANK_LINES^} option +The @option{--preserve-blank-lines} option turns off the squeezing; each blank line in the input is copied to the output. -The @option{^--insert-blank-lines^/INSERT_BLANK_LINES^} option +The @option{--insert-blank-lines} option causes additional blank lines to be inserted if not already present in the input (e.g. between bodies). @@ -14946,7 +14301,7 @@ with some exceptions. Comments that start in column 1 are kept there. If possible, comments are not moved so far to the right that the maximum line length is exceeded. -The @option{^-c0^/COMMENTS_LAYOUT=UNTOUCHED^} option +The @option{-c0} option turns off comment formatting. Special-form comments such as SPARK-style @code{--#...} are left alone. @@ -14955,7 +14310,7 @@ number of spaces between the end of the preceding Ada code and the beginning of the comment as appear in the original source. @noindent -The @option{^-c3^/COMMENTS_LAYOUT=GNAT_BEGINNING^} switch +The @option{-c3} switch (GNAT style comment beginning) has the following effect: @@ -14968,7 +14323,7 @@ first non-blank character of the comment. @end itemize @noindent -The @option{^-c4^/COMMENTS_LAYOUT=REFORMAT^} switch specifies that +The @option{-c4} switch specifies that whole-line comments that form a paragraph will be filled in typical word processor style (that is, moving words between lines to make the lines other than the last similar in length ). @@ -14992,53 +14347,48 @@ both. If @option{--comments-only} is given without @option{-c3} or the same casing as the corresponding defining identifier. You control the casing for defining occurrences via the -@option{^-n^/NAME_CASING^} switch. -@ifclear vms +@option{-n} switch. With @option{-nD} (``as declared'', which is the default), -@end ifclear -@ifset vms -With @option{/NAME_CASING=AS_DECLARED}, which is the default, -@end ifset defining occurrences appear exactly as in the source file where they are declared. -The other ^values for this switch^options for this qualifier^ --- -@option{^-nU^UPPER_CASE^}, -@option{^-nL^LOWER_CASE^}, -@option{^-nM^MIXED_CASE^} --- +The other values for this switch --- +@option{-nU}, +@option{-nL}, +@option{-nM} --- result in -^upper, lower, or mixed case, respectively^the corresponding casing^. +upper, lower, or mixed case, respectively. If @command{gnatpp} changes the casing of a defining occurrence, it analogously changes the casing of all the usage occurrences of this name. If the defining occurrence of a name is not in the source compilation unit currently being processed by @command{gnatpp}, the casing of each reference to -this name is changed according to the value of the @option{^-n^/NAME_CASING^} +this name is changed according to the value of the @option{-n} switch (subject to the dictionary file mechanism described below). -Thus @command{gnatpp} acts as though the @option{^-n^/NAME_CASING^} switch +Thus @command{gnatpp} acts as though the @option{-n} switch had affected the casing for the defining occurrence of the name. The options -@option{^-a@var{x}^/ATTRIBUTE^}, -@option{^-k@var{x}^/KEYWORD_CASING^}, -@option{^-ne@var{x}^/ENUM_CASING^}, -@option{^-nt@var{x}^/TYPE_CASING^}, -@option{^-nn@var{x}^/NUMBER_CASING^}, and -@option{^-p@var{x}^/PRAGMA_CASING^} +@option{-a@var{x}}, +@option{-k@var{x}}, +@option{-ne@var{x}}, +@option{-nt@var{x}}, +@option{-nn@var{x}}, and +@option{-p@var{x}} allow finer-grained control over casing for attributes, keywords, enumeration literals, types, named numbers and pragmas, respectively. -@option{^-nt@var{x}^/TYPE_CASING^} covers subtypes and +@option{-nt@var{x}} covers subtypes and task and protected bodies as well. Some names may need to be spelled with casing conventions that are not covered by the upper-, lower-, and mixed-case transformations. You can arrange correct casing by placing such names in a @emph{dictionary file}, -and then supplying a @option{^-D^/DICTIONARY^} switch. +and then supplying a @option{-D} switch. The casing of names from dictionary files overrides -any @option{^-n^/NAME_CASING^} switch. +any @option{-n} switch. To handle the casing of Ada predefined names and the names from GNAT libraries, @command{gnatpp} assumes a default dictionary file. @@ -15047,15 +14397,15 @@ for the entity in the @cite{Ada Reference Manual} (usually mixed case). The name of each entity in the GNAT libraries is spelled with the same casing as is used in the declaration of that entity. -The @w{@option{^-D-^/SPECIFIC_CASING^}} switch suppresses the use of +The @w{@option{-D-}} switch suppresses the use of the default dictionary file. Instead, the casing for predefined and GNAT-defined names will be established by the -@option{^-n^/NAME_CASING^} switch or explicit dictionary files. For +@option{-n} switch or explicit dictionary files. For example, by default the names @code{Ada.Text_IO} and @code{GNAT.OS_Lib} will appear as just shown, even in the presence of -a @option{^-nU^/NAME_CASING=UPPER_CASE^} switch. To ensure that even +a @option{-nU} switch. To ensure that even such names are rendered in uppercase, additionally supply the -@w{@option{^-D-^/SPECIFIC_CASING^}} switch (or else place these names +@w{@option{-D-}} switch (or else place these names in upper case in a dictionary file). A dictionary file is a plain text file; each line in this file can be @@ -15080,12 +14430,7 @@ The casing schema string can be followed by white space and/or an Ada-style comment; any amount of white space is allowed before the string. If a dictionary file is passed as -@ifclear vms the value of a @option{-D@var{file}} switch -@end ifclear -@ifset vms -an option to the @option{/DICTIONARY} qualifier -@end ifset then for every simple name and every identifier, @command{gnatpp} checks if the dictionary defines the casing for the name or for some of its parts (the term ``subword'' @@ -15124,14 +14469,14 @@ For example, suppose we have the following source to reformat: @smallexample @c ada @cartouche -procedure test is +@b{procedure} test @b{is} name1 : integer := 1; name4_name3_name2 : integer := 2; name2_name3_name4 : Boolean; name1_var : Float; -begin +@b{begin} name2_name3_name4 := name4_name3_name2 > name1; -end; +@b{end}; @end cartouche @end smallexample @@ -15156,12 +14501,7 @@ And suppose we have two dictionaries: If @command{gnatpp} is called with the following switches: @smallexample -@ifclear vms @command{gnatpp -nM -D dict1 -D dict2 test.adb} -@end ifclear -@ifset vms -@command{gnatpp test.adb /NAME_CASING=MIXED_CASE /DICTIONARY=(dict1, dict2)} -@end ifset @end smallexample @noindent @@ -15169,20 +14509,19 @@ then we will get the following name casing in the @command{gnatpp} output: @smallexample @c ada @cartouche -procedure Test is +@b{procedure} Test @b{is} NAME1 : Integer := 1; Name4_NAME3_Name2 : Integer := 2; Name2_NAME3_Name4 : Boolean; Name1_Var : Float; -begin +@b{begin} Name2_NAME3_Name4 := Name4_NAME3_Name2 > NAME1; -end Test; +@b{end} Test; @end cartouche @end smallexample @end ifclear @ifclear FSFEDITION -@ifclear vms @c ********************************* @node The Ada-to-XML converter gnat2xml @chapter The Ada-to-XML converter @command{gnat2xml} @@ -15197,6 +14536,7 @@ Ada source code into XML. * Switches for gnat2xml:: * Other Programs:: * Structure of the XML:: +* Generating Representation Clauses:: @end menu @node Switches for gnat2xml @@ -15239,7 +14579,8 @@ options: --incremental -- incremental processing on a per-file basis. Source files are only processed if they have been modified, or if files they depend on have been modified. This is similar to the way gnatmake/gprbuild - only compiles files that need to be recompiled. + only compiles files that need to be recompiled. A project file + is required in this mode. -j@var{n} -- In @option{--incremental} mode, use @var{n} @command{gnat2xml} processes to perform XML generation in parallel. If @var{n} is 0, then @@ -15251,13 +14592,16 @@ options: output.) -I - directories to search for dependencies - You can also set the ADA_INCLUDE_PATH environment variable for this. + directories to search for dependencies + You can also set the ADA_INCLUDE_PATH environment variable for this. --compact -- debugging version, with interspersed source, and a more compact representation of "sloc". This version does not conform to any schema. +--rep-clauses -- generate representation clauses (see ``Generating + Representation Clauses'' below). + -files=filename - the name of a text file containing a list of Ada source files to process @@ -15604,9 +14948,41 @@ formal_function formal_package formal_package_declaration_with_box @end smallexample -@end ifclear -@end ifclear +@node Generating Representation Clauses +@section Generating Representation Clauses + +@noindent +If the @option{--rep-clauses} switch is given, @command{gnat2xml} will +generate representation clauses for certain types showing the +representation chosen by the compiler. The information is produced by +the ASIS ``Data Decomposition'' facility --- see the +@code{Asis.Data_Decomposition} package for details. + +Not all types are supported. For example, @code{Type_Model_Kind} must +be @code{A_Simple_Static_Model}. Types declared within generic units +have no representation. The clauses that are generated include +@code{attribute_definition_clauses} for @code{Size} and +@code{Component_Size}, as well as +@code{record_representation_clauses}. + +There is no guarantee that the generated representation clauses could +have actually come from legal Ada code; Ada has some restrictions that +are not necessarily obeyed by the generated clauses. + +The representation clauses are surrounded by comment elements to +indicate that they are automatically generated, something like this: + +@smallexample + +... + +... + +... +@end smallexample + +@end ifclear @ifclear FSFEDITION @c ********************************* @@ -15616,7 +14992,7 @@ formal_package_declaration_with_box @cindex Metric tool @noindent -^The @command{gnatmetric} tool^@command{GNAT METRIC}^ is an ASIS-based utility +The @command{gnatmetric} tool is an ASIS-based utility for computing various program metrics. It takes an Ada source file as input and generates a file containing the metrics data as output. Various switches control which @@ -15637,6 +15013,13 @@ Project Files}). Another possibility is to specify the source search path and needed configuration files in @option{-cargs} section of @command{gnatmetric} call, see the description of the @command{gnatmetric} switches below. +If the set of sources to be processed by @code{gnatmetric} contains sources with +preprocessing directives +then the needed options should be provided to run preprocessor as a part of +the @command{gnatmetric} call, and the computed metrics +will correspond to preprocessed sources. + + The @command{gnatmetric} command has the form @smallexample @@ -15666,7 +15049,7 @@ Including both a @option{-files} switch and one or more @samp{@var{gcc_switches}} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatmetric} to generate the ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +@option{-I} switches to form the source search path, and use the @option{-gnatec} switch to set the configuration file, use the @option{-gnat05} switch if sources should be compiled in Ada 2005 mode etc. @@ -15704,7 +15087,7 @@ containing the computed metrics, except for the case when the set of metrics specified by gnatmetric parameters consists only of metrics that are computed for the whole set of analyzed sources, but not for each Ada source. By default, the name of the file containing metric information for a source -is obtained by appending the ^@file{.metrix}^@file{$METRIX}^ suffix to the +is obtained by appending the @file{.metrix} suffix to the name of the input source file. If not otherwise specified and no project file is specified as @command{gnatmetric} option this file is placed in the same directory as where the source file is located. If @command{gnatmetric} has a @@ -15715,7 +15098,7 @@ is specified, the files are placed in the subrirectory of this directory specified by this option. All the output information generated in XML format is placed in a single -file. By default the name of this file is ^@file{metrix.xml}^@file{METRIX$XML}^. +file. By default the name of this file is @file{metrix.xml}. If not otherwise specified and if no project file is specified as @command{gnatmetric} option this file is placed in the current directory. @@ -15728,44 +15111,44 @@ can be specified with the @option{-og} switch. The following switches control the @command{gnatmetric} output: @table @option -@cindex @option{^-x^/XML^} (@command{gnatmetric}) -@item ^-x^/XML^ +@cindex @option{-x} (@command{gnatmetric}) +@item -x Generate the XML output -@cindex @option{^-xs^/XSD^} (@command{gnatmetric}) -@item ^-xs^/XSD^ +@cindex @option{-xs} (@command{gnatmetric}) +@item -xs Generate the XML output and the XML schema file that describes the structure of the XML metric report, this schema is assigned to the XML file. The schema file has the same name as the XML output file with @file{.xml} suffix replaced with @file{.xsd} -@cindex @option{^-nt^/NO_TEXT^} (@command{gnatmetric}) -@item ^-nt^/NO_TEXT^ -Do not generate the output in text form (implies @option{^-x^/XML^}) +@cindex @option{-nt} (@command{gnatmetric}) +@item -nt +Do not generate the output in text form (implies @option{-x}) -@cindex @option{^-d^/DIRECTORY^} (@command{gnatmetric}) -@item ^-d @var{output_dir}^/DIRECTORY=@var{output_dir}^ +@cindex @option{-d} (@command{gnatmetric}) +@item -d @var{output_dir} Put text files with detailed metrics into @var{output_dir} -@cindex @option{^-o^/SUFFIX_DETAILS^} (@command{gnatmetric}) -@item ^-o @var{file_suffix}^/SUFFIX_DETAILS=@var{file_suffix}^ -Use @var{file_suffix}, instead of ^@file{.metrix}^@file{$METRIX}^ +@cindex @option{-o} (@command{gnatmetric}) +@item -o @var{file_suffix} +Use @var{file_suffix}, instead of @file{.metrix} in the name of the output file. -@cindex @option{^-og^/GLOBAL_OUTPUT^} (@command{gnatmetric}) -@item ^-og @var{file_name}^/GLOBAL_OUTPUT=@var{file_name}^ +@cindex @option{-og} (@command{gnatmetric}) +@item -og @var{file_name} Put global metrics into @var{file_name} -@cindex @option{^-ox^/XML_OUTPUT^} (@command{gnatmetric}) -@item ^-ox @var{file_name}^/XML_OUTPUT=@var{file_name}^ -Put the XML output into @var{file_name} (also implies @option{^-x^/XML^}) +@cindex @option{-ox} (@command{gnatmetric}) +@item -ox @var{file_name} +Put the XML output into @var{file_name} (also implies @option{-x}) -@cindex @option{^-sfn^/SHORT_SOURCE_FILE_NAME^} (@command{gnatmetric}) -@item ^-sfn^/SHORT_SOURCE_FILE_NAME^ +@cindex @option{-sfn} (@command{gnatmetric}) +@item -sfn Use ``short'' source file names in the output. (The @command{gnatmetric} output includes the name(s) of the Ada source file(s) from which the metrics are computed. By default each name includes the absolute path. The -@option{^-sfn^/SHORT_SOURCE_FILE_NAME^} switch causes @command{gnatmetric} +@option{-sfn} switch causes @command{gnatmetric} to exclude all directory information from the file names that are output.) @end table @@ -15813,8 +15196,8 @@ Suppression of metrics computation for eligible local units can be obtained via the following switch: @table @option -@cindex @option{^-nolocal^/SUPPRESS^} (@command{gnatmetric}) -@item ^-nolocal^/SUPPRESS=LOCAL_DETAILS^ +@cindex @option{-nolocal} (@command{gnatmetric}) +@item -nolocal Do not compute detailed metrics for eligible local program units @end table @@ -15885,62 +15268,60 @@ You can use the following switches to select the specific line metrics to be computed and reported. @table @option -@cindex @option{^--lines@var{x}^/LINE_COUNT_METRICS^} (@command{gnatmetric}) +@cindex @option{--lines@var{x}} (@command{gnatmetric}) -@ifclear vms @cindex @option{--no-lines@var{x}} -@end ifclear -@item ^--lines-all^/LINE_COUNT_METRICS=ALL^ +@item --lines-all Report all the line metrics -@item ^--no-lines-all^/LINE_COUNT_METRICS=NONE^ +@item --no-lines-all Do not report any of line metrics -@item ^--lines^/LINE_COUNT_METRICS=ALL_LINES^ +@item --lines Report the number of all lines -@item ^--no-lines^/LINE_COUNT_METRICS=NOALL_LINES^ +@item --no-lines Do not report the number of all lines -@item ^--lines-code^/LINE_COUNT_METRICS=CODE_LINES^ +@item --lines-code Report the number of code lines -@item ^--no-lines-code^/LINE_COUNT_METRICS=NOCODE_LINES^ +@item --no-lines-code Do not report the number of code lines -@item ^--lines-comment^/LINE_COUNT_METRICS=COMMENT_LINES^ +@item --lines-comment Report the number of comment lines -@item ^--no-lines-comment^/LINE_COUNT_METRICS=NOCOMMENT_LINES^ +@item --no-lines-comment Do not report the number of comment lines -@item ^--lines-eol-comment^/LINE_COUNT_METRICS=CODE_COMMENT_LINES^ +@item --lines-eol-comment Report the number of code lines containing end-of-line comments -@item ^--no-lines-eol-comment^/LINE_COUNT_METRICS=NOCODE_COMMENT_LINES^ +@item --no-lines-eol-comment Do not report the number of code lines containing end-of-line comments -@item ^--lines-ratio^/LINE_COUNT_METRICS=COMMENT_PERCENTAGE^ +@item --lines-ratio Report the comment percentage in the program text -@item ^--no-lines-ratio^/LINE_COUNT_METRICS=NOCOMMENT_PERCENTAGE^ +@item --no-lines-ratio Do not report the comment percentage in the program text -@item ^--lines-blank^/LINE_COUNT_METRICS=BLANK_LINES^ +@item --lines-blank Report the number of blank lines -@item ^--no-lines-blank^/LINE_COUNT_METRICS=NOBLANK_LINES^ +@item --no-lines-blank Do not report the number of blank lines -@item ^--lines-average^/LINE_COUNT_METRICS=AVERAGE_BODY_LINES^ +@item --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. -@item ^--no-lines-average^/LINE_COUNT_METRICS=NOAVERAGE_BODY_LINES^ +@item --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. @@ -16055,64 +15436,62 @@ following switches to select specific syntax metrics. @table @option -@cindex @option{^--syntax@var{x}^/SYNTAX_METRICS^} (@command{gnatmetric}) +@cindex @option{--syntax@var{x}} (@command{gnatmetric}) -@ifclear vms @cindex @option{--no-syntax@var{x}} (@command{gnatmetric}) -@end ifclear -@item ^--syntax-all^/SYNTAX_METRICS=ALL^ +@item --syntax-all Report all the syntax metrics -@item ^--no-syntax-all^/SYNTAX_METRICS=NONE^ +@item --no-syntax-all Do not report any of syntax metrics -@item ^--declarations^/SYNTAX_METRICS=DECLARATIONS^ +@item --declarations Report the total number of declarations -@item ^--no-declarations^/SYNTAX_METRICS=NODECLARATIONS^ +@item --no-declarations Do not report the total number of declarations -@item ^--statements^/SYNTAX_METRICS=STATEMENTS^ +@item --statements Report the total number of statements -@item ^--no-statements^/SYNTAX_METRICS=NOSTATEMENTS^ +@item --no-statements Do not report the total number of statements -@item ^--public-subprograms^/SYNTAX_METRICS=PUBLIC_SUBPROGRAMS^ +@item --public-subprograms Report the number of public subprograms in a compilation unit -@item ^--no-public-subprograms^/SYNTAX_METRICS=NOPUBLIC_SUBPROGRAMS^ +@item --no-public-subprograms Do not report the number of public subprograms in a compilation unit -@item ^--all-subprograms^/SYNTAX_METRICS=ALL_SUBPROGRAMS^ +@item --all-subprograms Report the number of all the subprograms in a compilation unit -@item ^--no-all-subprograms^/SYNTAX_METRICS=NOALL_SUBPROGRAMS^ +@item --no-all-subprograms Do not report the number of all the subprograms in a compilation unit -@item ^--public-types^/SYNTAX_METRICS=PUBLIC_TYPES^ +@item --public-types Report the number of public types in a compilation unit -@item ^--no-public-types^/SYNTAX_METRICS=NOPUBLIC_TYPES^ +@item --no-public-types Do not report the number of public types in a compilation unit -@item ^--all-types^/SYNTAX_METRICS=ALL_TYPES^ +@item --all-types Report the number of all the types in a compilation unit -@item ^--no-all-types^/SYNTAX_METRICS=NOALL_TYPES^ +@item --no-all-types Do not report the number of all the types in a compilation unit -@item ^--unit-nesting^/SYNTAX_METRICS=UNIT_NESTING^ +@item --unit-nesting Report the maximal program unit nesting level -@item ^--no-unit-nesting^/SYNTAX_METRICS=UNIT_NESTING_OFF^ +@item --no-unit-nesting Do not report the maximal program unit nesting level -@item ^--construct-nesting^/SYNTAX_METRICS=CONSTRUCT_NESTING^ +@item --construct-nesting Report the maximal construct nesting level -@item ^--no-construct-nesting^/SYNTAX_METRICS=NOCONSTRUCT_NESTING^ +@item --no-construct-nesting Do not report the maximal construct nesting level @end table @@ -16153,14 +15532,17 @@ and quantified expressions. For each body, we compute three metric values: @itemize @bullet @item the complexity introduced by control -statements only, without taking into account short-circuit forms, +statements only, without taking into account short-circuit forms +(referred as @code{statement complexity} in @command{gnatmetric} output), @item -the complexity introduced by short-circuit control forms only, and +the complexity introduced by short-circuit control forms only +(referred as @code{expression complexity} in @command{gnatmetric} output), and @item the total -cyclomatic complexity, which is the sum of these two values. +cyclomatic complexity, which is the sum of these two values +(referred as @code{cyclomatic complexity} in @command{gnatmetric} output). @end itemize @noindent @@ -16175,7 +15557,7 @@ of tests needed to satisfy paths coverage testing completeness criterion. Considered from the testing point of view, a static Ada @code{loop} (that is, the @code{loop} statement having static subtype in loop parameter specification) does not add to cyclomatic complexity. By providing -@option{^--no-static-loop^NO_STATIC_LOOP^} option a user +@option{--no-static-loop} option a user may specify that such loops should not be counted when computing the cyclomatic complexity metric @@ -16187,7 +15569,7 @@ or if it contains a @code{goto} statement that transfers the control outside the operator. A selective accept statement with @code{terminate} alternative is considered as non-structural statement. When computing this metric, @code{exit} statements are treated in the same way as @code{goto} -statements unless @option{^-ne^NO_EXITS_AS_GOTOS^} option is specified. +statements unless @option{-ne} option is specified. The Ada essential complexity metric defined here is intended to quantify the extent to which the software is unstructured. It is adapted from @@ -16206,63 +15588,61 @@ For more fine-grained control you can use the following switches: @table @option -@cindex @option{^-complexity@var{x}^/COMPLEXITY_METRICS^} (@command{gnatmetric}) +@cindex @option{-complexity@var{x}} (@command{gnatmetric}) -@ifclear vms @cindex @option{--no-complexity@var{x}} -@end ifclear -@item ^--complexity-all^/COMPLEXITY_METRICS=ALL^ +@item --complexity-all Report all the complexity metrics -@item ^--no-complexity-all^/COMPLEXITY_METRICS=NONE^ +@item --no-complexity-all Do not report any of complexity metrics -@item ^--complexity-cyclomatic^/COMPLEXITY_METRICS=CYCLOMATIC^ +@item --complexity-cyclomatic Report the McCabe Cyclomatic Complexity -@item ^--no-complexity-cyclomatic^/COMPLEXITY_METRICS=NOCYCLOMATIC^ +@item --no-complexity-cyclomatic Do not report the McCabe Cyclomatic Complexity -@item ^--complexity-essential^/COMPLEXITY_METRICS=ESSENTIAL^ +@item --complexity-essential Report the Essential Complexity -@item ^--no-complexity-essential^/COMPLEXITY_METRICS=NOESSENTIAL^ +@item --no-complexity-essential Do not report the Essential Complexity -@item ^--loop-nesting^/COMPLEXITY_METRICS=LOOP_NESTING_ON^ +@item --loop-nesting Report maximal loop nesting level -@item ^--no-loop-nesting^/COMPLEXITY_METRICS=NOLOOP_NESTING^ +@item --no-loop-nesting Do not report maximal loop nesting level -@item ^--complexity-average^/COMPLEXITY_METRICS=AVERAGE_COMPLEXITY^ +@item --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. -@item ^--no-complexity-average^/COMPLEXITY_METRICS=NOAVERAGE_COMPLEXITY^ +@item --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 -@cindex @option{^-ne^/NO_EXITS_AS_GOTOS^} (@command{gnatmetric}) -@item ^-ne^/NO_EXITS_AS_GOTOS^ +@cindex @option{-ne} (@command{gnatmetric}) +@item -ne Do not consider @code{exit} statements as @code{goto}s when computing Essential Complexity -@cindex @option{^--no-static-loop^/NO_STATIC_LOOP^} (@command{gnatmetric}) -@item ^--no-static-loop^/NO_STATIC_LOOP^ +@cindex @option{--no-static-loop} (@command{gnatmetric}) +@item --no-static-loop Do not consider static loops when computing cyclomatic complexity -@item ^--extra-exit-points^/EXTRA_EXIT_POINTS^ +@item --extra-exit-points Report the extra exit points for subprogram bodies. As an exit point, this metric counts @code{return} statements and raise statements in case when the raised exception is not handled in the same body. In case of a function this metric subtracts 1 from the number of exit points, because a function body must contain at least one @code{return} statement. -@item ^--no-extra-exit-points^/NOEXTRA_EXIT_POINTS^ +@item --no-extra-exit-points Do not report the extra exit points for subprogram bodies @end table @@ -16373,42 +15753,42 @@ and control coupling metrics: @smallexample @c ada @group -package Lib_1 is - function F_1 (I : Integer) return Integer; -end Lib_1; +@b{package} Lib_1 @b{is} + @b{function} F_1 (I : Integer) @b{return} Integer; +@b{end} Lib_1; @end group @group -package Lib_2 is - type T_2 is new Integer; -end Lib_2; +@b{package} Lib_2 @b{is} + @b{type} T_2 @b{is} @b{new} Integer; +@b{end} Lib_2; @end group @group -package body Lib_1 is - function F_1 (I : Integer) return Integer is - begin - return I + 1; - end F_1; -end Lib_1; +@b{package} @b{body} Lib_1 @b{is} + @b{function} F_1 (I : Integer) @b{return} Integer @b{is} + @b{begin} + @b{return} I + 1; + @b{end} F_1; +@b{end} Lib_1; @end group @group -with Lib_2; use Lib_2; -package Pack is +@b{with} Lib_2; @b{use} Lib_2; +@b{package} Pack @b{is} Var : T_2; - function Fun (I : Integer) return Integer; -end Pack; + @b{function} Fun (I : Integer) @b{return} Integer; +@b{end} Pack; @end group @group -with Lib_1; use Lib_1; -package body Pack is - function Fun (I : Integer) return Integer is - begin - return F_1 (I); - end Fun; -end Pack; +@b{with} Lib_1; @b{use} Lib_1; +@b{package} @b{body} Pack @b{is} + @b{function} Fun (I : Integer) @b{return} Integer @b{is} + @b{begin} + @b{return} F_1 (I); + @b{end} Fun; +@b{end} Pack; @end group @end smallexample @@ -16475,42 +15855,37 @@ switches to specify the coupling metrics to be computed and reported: @table @option -@ifclear vms @cindex @option{--tagged-coupling@var{x}} (@command{gnatmetric}) @cindex @option{--hierarchy-coupling@var{x}} (@command{gnatmetric}) @cindex @option{--unit-coupling@var{x}} (@command{gnatmetric}) @cindex @option{--control-coupling@var{x}} (@command{gnatmetric}) -@end ifclear -@ifset vms -@cindex @option{/COUPLING_METRICS} (@command{gnatmetric}) -@end ifset -@item ^--coupling-all^/COUPLING_METRICS=ALL^ +@item --coupling-all Report all the coupling metrics -@item ^--tagged-coupling-out^/COUPLING_METRICS=TAGGED_OUT^ +@item --tagged-coupling-out Report tagged (class) fan-out coupling -@item ^--tagged-coupling-in^/COUPLING_METRICS=TAGGED_IN^ +@item --tagged-coupling-in Report tagged (class) fan-in coupling -@item ^--hierarchy-coupling-out^/COUPLING_METRICS=HIERARCHY_OUT^ +@item --hierarchy-coupling-out Report hierarchy (category) fan-out coupling -@item ^--hierarchy-coupling-in^/COUPLING_METRICS=HIERARCHY_IN^ +@item --hierarchy-coupling-in Report hierarchy (category) fan-in coupling -@item ^--unit-coupling-out^/COUPLING_METRICS=UNIT_OUT^ +@item --unit-coupling-out Report unit fan-out coupling -@item ^--unit-coupling-in^/COUPLING_METRICS=UNIT_IN^ +@item --unit-coupling-in Report unit fan-in coupling -@item ^--control-coupling-out^/COUPLING_METRICS=CONTROL_OUT^ +@item --control-coupling-out Report control fan-out coupling -@item ^--control-coupling-in^/COUPLING_METRICS=CONTROL_IN^ +@item --control-coupling-in Report control fan-in coupling @end table @@ -16568,33 +15943,33 @@ project objects directory. This corresponds to the @command{gnatcheck} behavior when it is called with the project file from the GNAT driver. Has no effect if no project is specified. -@item ^-files @var{filename}^/FILES=@var{filename}^ -@cindex @option{^-files^/FILES^} (@code{gnatmetric}) +@item -files @var{filename} +@cindex @option{-files} (@code{gnatmetric}) Take the argument source files from the specified file. This file should be an ordinary text file containing file names separated by spaces or line breaks. You can use this switch more than once in the same call to @command{gnatmetric}. You also can combine this switch with an explicit list of files. -@item ^-j^/PROCESSES=^@var{n} -@cindex @option{^-j^/PROCESSES^} (@command{gnatmetric}) +@item -j@var{n} +@cindex @option{-j} (@command{gnatmetric}) Use @var{n} processes to carry out the tree creations (internal representations of the argument sources). On a multiprocessor machine this speeds up processing of big sets of argument sources. If @var{n} is 0, then the maximum number of parallel tree creations is the number of core processors on the platform. -@cindex @option{^-t^/TIME^} (@command{gnatmetric}) -@item ^-t^/TIME^ +@cindex @option{-t} (@command{gnatmetric}) +@item -t Print out execution time. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@command{gnatmetric}) +@item -v +@cindex @option{-v} (@command{gnatmetric}) Verbose mode; @command{gnatmetric} generates version information and then a trace of sources being processed. -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@command{gnatmetric}) +@item -q +@cindex @option{-q} (@command{gnatmetric}) Quiet mode. @end table @@ -16665,18 +16040,18 @@ Take the unit name and replace all dots by hyphens. @item If such a replacement occurs in the second character position of a name, and the first character is -^@samp{a}, @samp{g}, @samp{s}, or @samp{i}, ^@samp{A}, @samp{G}, @samp{S}, or @samp{I},^ +@samp{a}, @samp{g}, @samp{s}, or @samp{i}, then replace the dot by the character -^@samp{~} (tilde)^@samp{$} (dollar sign)^ +@samp{~} (tilde) instead of a minus. @end itemize The reason for this exception is to avoid clashes with the standard names for children of System, Ada, Interfaces, and GNAT, which use the prefixes -^@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-},^@samp{S-}, @samp{A-}, @samp{I-}, and @samp{G-},^ +@samp{s-}, @samp{a-}, @samp{i-}, and @samp{g-}, respectively. -The @option{^-gnatk^/FILE_NAME_MAX_LENGTH=^@var{nn}} +The @option{-gnatk@var{nn}} switch of the compiler activates a ``krunching'' circuit that limits file names to nn characters (where nn is a decimal integer). For example, using OpenVMS, @@ -16695,19 +16070,12 @@ a given file, when krunched to a specified maximum length. @noindent The @code{gnatkr} command has the form -@ifclear vms @smallexample @c $ gnatkr @var{name} @ovar{length} @c Expanding @ovar macro inline (explanation in macro def comments) $ gnatkr @var{name} @r{[}@var{length}@r{]} @end smallexample -@end ifclear -@ifset vms -@smallexample -$ gnatkr @var{name} /COUNT=nn -@end smallexample -@end ifset @noindent @var{name} is the uncrunched file name, derived from the name of the unit @@ -16729,7 +16097,7 @@ Note that the result is always all lower case (except on OpenVMS where it is all upper case). Characters of the other case are folded as required. @var{length} represents the length of the krunched name. The default -when no argument is given is ^8^39^ characters. A length of zero stands for +when no argument is given is 8 characters. A length of zero stands for unlimited, in other words do not chop except for system files where the implied crunching length is always eight characters. @@ -16744,10 +16112,10 @@ original argument was a file name with an extension. The initial file name is determined by the name of the unit that the file contains. The name is formed by taking the full expanded name of the unit and replacing the separating dots with hyphens and -using ^lowercase^uppercase^ +using lowercase for all letters, except that a hyphen in the second character position is -replaced by a ^tilde^dollar sign^ if the first character is -^@samp{a}, @samp{i}, @samp{g}, or @samp{s}^@samp{A}, @samp{I}, @samp{G}, or @samp{S}^. +replaced by a tilde if the first character is +@samp{a}, @samp{i}, @samp{g}, or @samp{s}. The extension is @code{.ads} for a spec and @code{.adb} for a body. Krunching does not affect the extension, but the file name is shortened to @@ -16791,21 +16159,21 @@ special prefix replacements: @table @file @item ada- -replaced by @file{^a^A^-} +replaced by @file{a-} @item gnat- -replaced by @file{^g^G^-} +replaced by @file{g-} @item interfaces- -replaced by @file{^i^I^-} +replaced by @file{i-} @item system- -replaced by @file{^s^S^-} +replaced by @file{s-} @end table These system files have a hyphen in the second character position. That is why normal user files replace such a character with a -^tilde^dollar sign^, to +tilde, to avoid confusion with system file names. As an example of this special rule, consider @@ -16841,12 +16209,10 @@ krunched name of a file. @iftex @leftskip=0cm @end iftex -@ifclear vms $ gnatkr very_long_unit_name.ads --> velounna.ads $ gnatkr grandparent-parent-child.ads --> grparchi.ads $ gnatkr Grandparent.Parent.Child.ads --> grparchi.ads $ gnatkr grandparent-parent-child --> grparchi -@end ifclear $ gnatkr very_long_unit_name.ads/count=6 --> vlunna.ads $ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads @end smallexample @@ -16920,21 +16286,21 @@ optional, and can be replaced by the use of the @option{-D} switch. @table @option @c !sort! -@item ^-b^/BLANK_LINES^ -@cindex @option{^-b^/BLANK_LINES^} (@command{gnatprep}) +@item -b +@cindex @option{-b} (@command{gnatprep}) Causes both preprocessor lines and the lines deleted by preprocessing to be replaced by blank lines in the output source file, preserving line numbers in the output file. -@item ^-c^/COMMENTS^ -@cindex @option{^-c^/COMMENTS^} (@command{gnatprep}) +@item -c +@cindex @option{-c} (@command{gnatprep}) Causes both preprocessor lines and the lines deleted by preprocessing to be retained in the output source as comments marked with the special string @code{"--! "}. This option will result in line numbers being preserved in the output file. -@item ^-C^/REPLACE_IN_COMMENTS^ -@cindex @option{^-C^/REPLACE_IN_COMMENTS^} (@command{gnatprep}) +@item -C +@cindex @option{-C} (@command{gnatprep}) Causes comments to be scanned. Normally comments are ignored by gnatprep. If this option is specified, then comments are scanned and any $symbol substitutions performed as in program text. This is particularly useful @@ -16943,57 +16309,49 @@ SPARK dialect of Ada). Note that this switch is not available when doing integrated preprocessing (it would be useless in this context since comments are ignored by the compiler in any case). -@item ^-Dsymbol=value^/ASSOCIATE="symbol=value"^ -@cindex @option{^-D^/ASSOCIATE^} (@command{gnatprep}) +@item -Dsymbol=value +@cindex @option{-D} (@command{gnatprep}) Defines a new preprocessing symbol, associated with value. If no value is given on the command line, then symbol is considered to be @code{True}. This switch can be used in place of a definition file. -@ifset vms -@item /REMOVE -@cindex @option{/REMOVE} (@command{gnatprep}) -This is the default setting which causes lines deleted by preprocessing -to be entirely removed from the output file. -@end ifset -@item ^-r^/REFERENCE^ -@cindex @option{^-r^/REFERENCE^} (@command{gnatprep}) +@item -r +@cindex @option{-r} (@command{gnatprep}) Causes a @code{Source_Reference} pragma to be generated that references the original input file, so that error messages will use the file name of this original file. The use of this switch implies that preprocessor lines are not to be removed from the file, so its -use will force @option{^-b^/BLANK_LINES^} mode if -@option{^-c^/COMMENTS^} +use will force @option{-b} mode if +@option{-c} has not been specified explicitly. Note that if the file to be preprocessed contains multiple units, then it will be necessary to @code{gnatchop} the output file from @code{gnatprep}. If a @code{Source_Reference} pragma is present in the preprocessed file, it will be respected by -@code{gnatchop ^-r^/REFERENCE^} +@code{gnatchop -r} so that the final chopped files will correctly refer to the original input source file for @code{gnatprep}. -@item ^-s^/SYMBOLS^ -@cindex @option{^-s^/SYMBOLS^} (@command{gnatprep}) +@item -s +@cindex @option{-s} (@command{gnatprep}) Causes a sorted list of symbol names and values to be listed on the standard output file. -@item ^-u^/UNDEFINED^ -@cindex @option{^-u^/UNDEFINED^} (@command{gnatprep}) +@item -u +@cindex @option{-u} (@command{gnatprep}) Causes undefined symbols to be treated as having the value FALSE in the context of a preprocessor test. In the absence of this option, an undefined symbol in a @code{#if} or @code{#elsif} test will be treated as an error. @end table -@ifclear vms @noindent Note: if neither @option{-b} nor @option{-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. -@end ifclear @node Form of Definitions File @section Form of Definitions File @@ -17207,14 +16565,14 @@ Here is a simple example of use: @smallexample $ gnatls *.o -^./^[]^demo1.o demo1 DIF demo1.adb -^./^[]^demo2.o demo2 OK demo2.adb -^./^[]^hello.o h1 OK hello.adb -^./^[]^instr-child.o instr.child MOK instr-child.adb -^./^[]^instr.o instr OK instr.adb -^./^[]^tef.o tef DIF tef.adb -^./^[]^text_io_example.o text_io_example OK text_io_example.adb -^./^[]^tgef.o tgef DIF tgef.adb +./demo1.o demo1 DIF demo1.adb +./demo2.o demo2 OK demo2.adb +./hello.o h1 OK hello.adb +./instr-child.o instr.child MOK instr-child.adb +./instr.o instr OK instr.adb +./tef.o tef DIF tef.adb +./text_io_example.o text_io_example OK text_io_example.adb +./tgef.o tgef DIF tgef.adb @end smallexample @noindent @@ -17234,7 +16592,7 @@ specified unit corresponds exactly to the actual source file. The version of the source file used for the compilation of the specified unit differs from the actual source file but not enough to require recompilation. If you use gnatmake with the qualifier -@option{^-m (minimal recompilation)^/MINIMAL_RECOMPILATION^}, a file marked +@option{-m (minimal recompilation)}, a file marked MOK will not be recompiled. @item DIF (modified) @@ -17267,52 +16625,52 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^-a^/ALL_UNITS^ -@cindex @option{^-a^/ALL_UNITS^} (@code{gnatls}) +@item -a +@cindex @option{-a} (@code{gnatls}) Consider all units, including those of the predefined Ada library. -Especially useful with @option{^-d^/DEPENDENCIES^}. +Especially useful with @option{-d}. -@item ^-d^/DEPENDENCIES^ -@cindex @option{^-d^/DEPENDENCIES^} (@code{gnatls}) +@item -d +@cindex @option{-d} (@code{gnatls}) List sources from which specified units depend on. -@item ^-h^/OUTPUT=OPTIONS^ -@cindex @option{^-h^/OUTPUT=OPTIONS^} (@code{gnatls}) +@item -h +@cindex @option{-h} (@code{gnatls}) Output the list of options. -@item ^-o^/OUTPUT=OBJECTS^ -@cindex @option{^-o^/OUTPUT=OBJECTS^} (@code{gnatls}) +@item -o +@cindex @option{-o} (@code{gnatls}) Only output information about object files. -@item ^-s^/OUTPUT=SOURCES^ -@cindex @option{^-s^/OUTPUT=SOURCES^} (@code{gnatls}) +@item -s +@cindex @option{-s} (@code{gnatls}) Only output information about source files. -@item ^-u^/OUTPUT=UNITS^ -@cindex @option{^-u^/OUTPUT=UNITS^} (@code{gnatls}) +@item -u +@cindex @option{-u} (@code{gnatls}) Only output information about compilation units. -@item ^-files^/FILES^=@var{file} -@cindex @option{^-files^/FILES^} (@code{gnatls}) +@item -files=@var{file} +@cindex @option{-files} (@code{gnatls}) Take as arguments the files listed in text file @var{file}. Text file @var{file} may contain empty lines that are ignored. Each nonempty line should contain the name of an existing file. Several such switches may be specified simultaneously. -@item ^-aO^/OBJECT_SEARCH=^@var{dir} -@itemx ^-aI^/SOURCE_SEARCH=^@var{dir} -@itemx ^-I^/SEARCH=^@var{dir} -@itemx ^-I-^/NOCURRENT_DIRECTORY^ +@item -aO@var{dir} +@itemx -aI@var{dir} +@itemx -I@var{dir} +@itemx -I- @itemx -nostdinc -@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatls}) -@cindex @option{^-aI^/SOURCE_SEARCH^} (@code{gnatls}) -@cindex @option{^-I^/SEARCH^} (@code{gnatls}) -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatls}) +@cindex @option{-aO} (@code{gnatls}) +@cindex @option{-aI} (@code{gnatls}) +@cindex @option{-I} (@code{gnatls}) +@cindex @option{-I-} (@code{gnatls}) Source path manipulation. Same meaning as the equivalent @command{gnatmake} flags (@pxref{Switches for gnatmake}). -@item ^-aP^/ADD_PROJECT_SEARCH_DIR=^@var{dir} -@cindex @option{^-aP^/ADD_PROJECT_SEARCH_DIR=^} (@code{gnatls}) +@item -aP@var{dir} +@cindex @option{-aP} (@code{gnatls}) Add @var{dir} at the beginning of the project search dir. @item --RTS=@var{rts-path} @@ -17320,8 +16678,8 @@ Add @var{dir} at the beginning of the project search dir. Specifies the default location of the runtime library. Same meaning as the equivalent @command{gnatmake} flag (@pxref{Switches for gnatmake}). -@item ^-v^/OUTPUT=VERBOSE^ -@cindex @option{^-v^/OUTPUT=VERBOSE^} (@code{gnatls}) +@item -v +@cindex @option{-v} (@code{gnatls}) Verbose mode. Output the complete source, object and project paths. Do not use the default column layout but instead use long format giving as much as information possible on each requested units, including special @@ -17359,7 +16717,6 @@ The unit contains a pragma Remote_Call_Interface. @node Examples of gnatls Usage @section Example of @code{gnatls} Usage -@ifclear vms @noindent Example of using the verbose switch. Note how the source and @@ -17431,36 +16788,7 @@ instr.ads /home/comar/local/adainclude/s-unstyp.ads /home/comar/local/adainclude/unchconv.ads @end smallexample -@end ifclear - -@ifset vms -@smallexample -GNAT LIST /DEPENDENCIES /OUTPUT=SOURCES /ALL_UNITS DEMO1.ADB -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]ada.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-finali.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-filico.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-stream.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]a-tags.ads -demo1.adb -gen_list.ads -gen_list.adb -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]gnat.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]g-io.ads -instr.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]system.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-exctab.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finimp.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-finroo.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-secsta.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stalib.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stoele.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-stratt.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-tasoli.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]s-unstyp.ads -GNU:[LIB.OPENVMS7_1.2_8_1.ADALIB]unchconv.ads -@end smallexample -@end ifset @node Cleaning Up with gnatclean @chapter Cleaning Up with @code{gnatclean} @@ -17490,15 +16818,15 @@ $ gnatclean switches @var{names} @end smallexample @noindent -@var{names} is a list of source file names. Suffixes @code{.^ads^ADS^} and -@code{^adb^ADB^} may be omitted. If a project file is specified using switch -@code{^-P^/PROJECT_FILE=^}, then @var{names} may be completely omitted. +@var{names} is a list of source file names. Suffixes @code{.ads} and +@code{adb} may be omitted. If a project file is specified using switch +@code{-P}, then @var{names} may be completely omitted. @noindent In normal mode, @code{gnatclean} delete the files produced by the compiler and, -if switch @code{^-c^/COMPILER_FILES_ONLY^} is not specified, by the binder and +if switch @code{-c} is not specified, by the binder and the linker. In informative-only mode, specified by switch -@code{^-n^/NODELETE^}, the list of files that would have been deleted in +@code{-n}, the list of files that would have been deleted in normal mode is listed, but no file is actually deleted. @node Switches for gnatclean @@ -17517,90 +16845,90 @@ Display Copyright and version, then exit disregarding all other options. If @option{--version} was not used, display usage, then exit disregarding all other options. -@item ^--subdirs^/SUBDIRS^=subdir +@item --subdirs=subdir Actual object directory of each project file is the subdirectory subdir of the object directory specified or defaulted in the project file. -@item ^--unchecked-shared-lib-imports^/UNCHECKED_SHARED_LIB_IMPORTS^ +@item --unchecked-shared-lib-imports By default, shared library projects are not allowed to import static library projects. When this switch is used on the command line, this restriction is relaxed. -@item ^-c^/COMPILER_FILES_ONLY^ -@cindex @option{^-c^/COMPILER_FILES_ONLY^} (@code{gnatclean}) +@item -c +@cindex @option{-c} (@code{gnatclean}) Only attempt to delete the files produced by the compiler, not those produced by the binder or the linker. The files that are not to be deleted are library files, interface copy files, binder generated files and executable files. -@item ^-D ^/DIRECTORY_OBJECTS=^@var{dir} -@cindex @option{^-D^/DIRECTORY_OBJECTS^} (@code{gnatclean}) +@item -D @var{dir} +@cindex @option{-D} (@code{gnatclean}) Indicate that ALI and object files should normally be found in directory @var{dir}. -@item ^-F^/FULL_PATH_IN_BRIEF_MESSAGES^ -@cindex @option{^-F^/FULL_PATH_IN_BRIEF_MESSAGES^} (@code{gnatclean}) +@item -F +@cindex @option{-F} (@code{gnatclean}) When using project files, if some errors or warnings are detected during parsing and verbose mode is not in effect (no use of switch -^-v^/VERBOSE^), then error lines start with the full path name of the project +-v), then error lines start with the full path name of the project file, rather than its simple file name. -@item ^-h^/HELP^ -@cindex @option{^-h^/HELP^} (@code{gnatclean}) -Output a message explaining the usage of @code{^gnatclean^gnatclean^}. +@item -h +@cindex @option{-h} (@code{gnatclean}) +Output a message explaining the usage of @code{gnatclean}. -@item ^-n^/NODELETE^ -@cindex @option{^-n^/NODELETE^} (@code{gnatclean}) +@item -n +@cindex @option{-n} (@code{gnatclean}) Informative-only mode. Do not delete any files. Output the list of the files that would have been deleted if this switch was not specified. -@item ^-P^/PROJECT_FILE=^@var{project} -@cindex @option{^-P^/PROJECT_FILE^} (@code{gnatclean}) +@item -P@var{project} +@cindex @option{-P} (@code{gnatclean}) Use project file @var{project}. Only one such switch can be used. When cleaning a project file, the files produced by the compilation of the immediate sources or inherited sources of the project files are to be deleted. This is not depending on the presence or not of executable names on the command line. -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@code{gnatclean}) +@item -q +@cindex @option{-q} (@code{gnatclean}) Quiet output. If there are no errors, do not output anything, except in -verbose mode (switch ^-v^/VERBOSE^) or in informative-only mode -(switch ^-n^/NODELETE^). +verbose mode (switch -v) or in informative-only mode +(switch -n). -@item ^-r^/RECURSIVE^ -@cindex @option{^-r^/RECURSIVE^} (@code{gnatclean}) -When a project file is specified (using switch ^-P^/PROJECT_FILE=^), +@item -r +@cindex @option{-r} (@code{gnatclean}) +When a project file is specified (using switch -P), clean all imported and extended project files, recursively. If this switch is not specified, only the files related to the main project file are to be deleted. This switch has no effect if no project file is specified. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@code{gnatclean}) +@item -v +@cindex @option{-v} (@code{gnatclean}) Verbose mode. -@item ^-vP^/MESSAGES_PROJECT_FILE=^@emph{x} -@cindex @option{^-vP^/MESSAGES_PROJECT_FILE^} (@code{gnatclean}) +@item -vP@emph{x} +@cindex @option{-vP} (@code{gnatclean}) Indicates the verbosity of the parsing of GNAT project files. @xref{Switches Related to Project Files}. -@item ^-X^/EXTERNAL_REFERENCE=^@var{name=value} -@cindex @option{^-X^/EXTERNAL_REFERENCE^} (@code{gnatclean}) +@item -X@var{name=value} +@cindex @option{-X} (@code{gnatclean}) Indicates that external variable @var{name} has the value @var{value}. The Project Manager will use this value for occurrences of @code{external(name)} when parsing the project file. @xref{Switches Related to Project Files}. -@item ^-aO^/OBJECT_SEARCH=^@var{dir} -@cindex @option{^-aO^/OBJECT_SEARCH^} (@code{gnatclean}) +@item -aO@var{dir} +@cindex @option{-aO} (@code{gnatclean}) When searching for ALI and object files, look in directory @var{dir}. -@item ^-I^/SEARCH=^@var{dir} -@cindex @option{^-I^/SEARCH^} (@code{gnatclean}) -Equivalent to @option{^-aO^/OBJECT_SEARCH=^@var{dir}}. +@item -I@var{dir} +@cindex @option{-I} (@code{gnatclean}) +Equivalent to @option{-aO@var{dir}}. -@item ^-I-^/NOCURRENT_DIRECTORY^ -@cindex @option{^-I-^/NOCURRENT_DIRECTORY^} (@code{gnatclean}) +@item -I- +@cindex @option{-I-} (@code{gnatclean}) @cindex Source files, suppressing search Do not look for ALI or object files in the directory where @code{gnatclean} was invoked. @@ -17610,7 +16938,6 @@ where @code{gnatclean} was invoked. @c @node Examples of gnatclean Usage @c @section Examples of @code{gnatclean} Usage -@ifclear vms @node GNAT and Libraries @chapter GNAT and Libraries @cindex Library, building, installing, using @@ -17720,13 +17047,13 @@ to the specified location). Here is a simple library project file: @smallexample @c ada -project My_Lib is - for Source_Dirs use ("src1", "src2"); - for Object_Dir use "obj"; - for Library_Name use "mylib"; - for Library_Dir use "lib"; - for Library_Kind use "dynamic"; -end My_lib; +project My_Lib @b{is} + @b{for} Source_Dirs @b{use} ("src1", "src2"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Library_Name @b{use} "mylib"; + @b{for} Library_Dir @b{use} "lib"; + @b{for} Library_Kind @b{use} "dynamic"; +@b{end} My_lib; @end smallexample @noindent @@ -17755,13 +17082,13 @@ of the underlying operating system to produce the static or shared library. Here is an example of such a dummy program: @smallexample @c ada @group -with My_Lib.Service1; -with My_Lib.Service2; -with My_Lib.Service3; -procedure My_Lib_Dummy is -begin - null; -end; +@b{with} My_Lib.Service1; +@b{with} My_Lib.Service2; +@b{with} My_Lib.Service3; +@b{procedure} My_Lib_Dummy @b{is} +@b{begin} + @b{null}; +@b{end}; @end group @end smallexample @@ -17859,10 +17186,10 @@ library @code{My_Lib} shown in examples in earlier sections, you can write: @smallexample @c projectfile -with "my_lib"; -project My_Proj is +@b{with} "my_lib"; +@b{project} My_Proj @b{is} @dots{} -end My_Proj; +@b{end} My_Proj; @end smallexample Even if you have a third-party, non-Ada library, you can still use GNAT's @@ -17872,13 +17199,13 @@ third-party library @file{liba.a}: @smallexample @c projectfile @group -project Liba is - for Externally_Built use "true"; - for Source_Files use (); - for Library_Dir use "lib"; - for Library_Name use "a"; - for Library_Kind use "static"; -end Liba; +@b{project} Liba @b{is} + @b{for} Externally_Built @b{use} "true"; + @b{for} Source_Files @b{use} (); + @b{for} Library_Dir @b{use} "lib"; + @b{for} Library_Name @b{use} "a"; + @b{for} Library_Kind @b{use} "static"; +@b{end} Liba; @end group @end smallexample This is an alternative to the use of @code{pragma Linker_Options}. It is @@ -17923,10 +17250,15 @@ a pragma @code{Linker_Options} has been added to one of the sources. For example: @smallexample @c ada -pragma Linker_Options ("-lmy_lib"); +@b{pragma} Linker_Options ("-lmy_lib"); @end smallexample @end itemize +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 +install area. + @node Stand-alone Ada Libraries @section Stand-alone Ada Libraries @cindex Stand-alone library, building, using @@ -17985,9 +17317,9 @@ that make a project a Library Project (@code{Library_Name} and @smallexample @c projectfile @group - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Interface use ("int1", "int1.child"); + @b{for} Library_Dir @b{use} "lib_dir"; + @b{for} Library_Name @b{use} "dummy"; + @b{for} Library_Interface @b{use} ("int1", "int1.child"); @end group @end smallexample @@ -17998,7 +17330,7 @@ of the project file. When a Stand-alone Library is built, first the binder is invoked to build a package whose name depends on the library name -(@file{^b~dummy.ads/b^B$DUMMY.ADS/B^} in the example above). +(@file{b~dummy.ads/b} in the example above). This binder-generated package includes initialization and finalization procedures whose names depend on the library name (@code{dummyinit} and @code{dummyfinal} @@ -18028,11 +17360,11 @@ build an encapsulated library the attribute @smallexample @c projectfile @group - for Library_Dir use "lib_dir"; - for Library_Name use "dummy"; - for Library_Kind use "dynamic"; - for Library_Interface use ("int1", "int1.child"); - for Library_Standalone use "encapsulated"; + @b{for} Library_Dir @b{use} "lib_dir"; + @b{for} Library_Name @b{use} "dummy"; + @b{for} Library_Kind @b{use} "dynamic"; + @b{for} Library_Interface @b{use} ("int1", "int1.child"); + @b{for} Library_Standalone @b{use} "encapsulated"; @end group @end smallexample @@ -18108,15 +17440,15 @@ or @code{pragma Convention}. Here is an example of simple library interface for use with C main program: @smallexample @c ada -package My_Package is +@b{package} My_Package @b{is} - procedure Do_Something; - pragma Export (C, Do_Something, "do_something"); + @b{procedure} Do_Something; + @b{pragma} Export (C, Do_Something, "do_something"); - procedure Do_Something_Else; - pragma Export (C, Do_Something_Else, "do_something_else"); + @b{procedure} Do_Something_Else; + @b{pragma} Export (C, Do_Something_Else, "do_something_else"); -end My_Package; +@b{end} My_Package; @end smallexample @noindent @@ -18523,7 +17855,6 @@ export ADA_OBJECTS_PATH all: gnatmake main_unit @end smallexample -@end ifclear @node Memory Management Issues @chapter Memory Management Issues @@ -18532,21 +17863,17 @@ all: This chapter describes some useful memory pools provided in the GNAT library and in particular the GNAT Debug Pool facility, which can be used to detect incorrect uses of access values (including ``dangling references''). -@ifclear vms @ifclear FSFEDITION It also describes the @command{gnatmem} tool, which can be used to track down ``memory leaks''. @end ifclear -@end ifclear @menu * Some Useful Memory Pools:: * The GNAT Debug Pool Facility:: -@ifclear vms @ifclear FSFEDITION * The gnatmem Tool:: @end ifclear -@end ifclear @end menu @node Some Useful Memory Pools @@ -18564,12 +17891,12 @@ pools but if they did, they could use this storage pool without any change in behavior. That is why this storage pool is used when the user manages to make the default implicit allocator explicit as in this example: @smallexample @c ada - type T1 is access Something; - -- no Storage pool is defined for T2 - type T2 is access Something_Else; - for T2'Storage_Pool use T1'Storage_Pool; - -- the above is equivalent to - for T2'Storage_Pool use System.Pool_Global.Global_Pool_Object; + @b{type} T1 @b{is} @b{access} Something; + --@i{ no Storage pool is defined for T2} + @b{type} T2 @b{is} @b{access} Something_Else; + @b{for} T2'Storage_Pool @b{use} T1'Storage_Pool; + --@i{ the above is equivalent to} + @b{for} T2'Storage_Pool @b{use} System.Pool_Global.Global_Pool_Object; @end smallexample @noindent @@ -18584,23 +17911,23 @@ scope of a given local access. As an example, the following program does not leak memory even though it does not perform explicit deallocation: @smallexample @c ada -with System.Pool_Local; -procedure Pooloc1 is - procedure Internal is - type A is access Integer; +@b{with} System.Pool_Local; +@b{procedure} Pooloc1 @b{is} + @b{procedure} Internal @b{is} + @b{type} A @b{is} @b{access} Integer; X : System.Pool_Local.Unbounded_Reclaim_Pool; - for A'Storage_Pool use X; + @b{for} A'Storage_Pool @b{use} X; v : A; - begin - for I in 1 .. 50 loop - v := new Integer; - end loop; - end Internal; -begin - for I in 1 .. 100 loop + @b{begin} + @b{for} I @b{in} 1 .. 50 @b{loop} + v := @b{new} Integer; + @b{end} @b{loop}; + @b{end} Internal; +@b{begin} + @b{for} I @b{in} 1 .. 100 @b{loop} Internal; - end loop; -end Pooloc1; + @b{end} @b{loop}; +@b{end} Pooloc1; @end smallexample @noindent @@ -18613,8 +17940,8 @@ access type is defined. This package is not intended to be used directly by the user and it is implicitly used for each such declaration: @smallexample @c ada - type T1 is access Something; - for T1'Storage_Size use 10_000; + @b{type} T1 @b{is} @b{access} Something; + @b{for} T1'Storage_Size @b{use} 10_000; @end smallexample @node The GNAT Debug Pool Facility @@ -18634,9 +17961,9 @@ In order to use the GNAT specific debugging pool, the user must associate a debug pool object with each of the access types that may be related to suspected memory problems. See Ada Reference Manual 13.11. @smallexample @c ada -type Ptr is access Some_Type; +@b{type} Ptr @b{is} @b{access} Some_Type; Pool : GNAT.Debug_Pools.Debug_Pool; -for Ptr'Storage_Pool use Pool; +@b{for} Ptr'Storage_Pool @b{use} Pool; @end smallexample @noindent @@ -18680,56 +18007,56 @@ properly allocated memory location. Here is a complete example of use of @iftex @leftskip=0cm @end iftex -with Gnat.Io; use Gnat.Io; -with Unchecked_Deallocation; -with Unchecked_Conversion; -with GNAT.Debug_Pools; -with System.Storage_Elements; -with Ada.Exceptions; use Ada.Exceptions; -procedure Debug_Pool_Test is +@b{with} Gnat.Io; @b{use} Gnat.Io; +@b{with} Unchecked_Deallocation; +@b{with} Unchecked_Conversion; +@b{with} GNAT.Debug_Pools; +@b{with} System.Storage_Elements; +@b{with} Ada.Exceptions; @b{use} Ada.Exceptions; +@b{procedure} Debug_Pool_Test @b{is} - type T is access Integer; - type U is access all T; + @b{type} T @b{is} @b{access} Integer; + @b{type} U @b{is} @b{access} @b{all} T; P : GNAT.Debug_Pools.Debug_Pool; - for T'Storage_Pool use P; + @b{for} T'Storage_Pool @b{use} P; - procedure Free is new Unchecked_Deallocation (Integer, T); - function UC is new Unchecked_Conversion (U, T); - A, B : aliased T; + @b{procedure} Free @b{is} @b{new} Unchecked_Deallocation (Integer, T); + @b{function} UC @b{is} @b{new} Unchecked_Conversion (U, T); + A, B : @b{aliased} T; - procedure Info is new GNAT.Debug_Pools.Print_Info(Put_Line); + @b{procedure} Info @b{is} @b{new} GNAT.Debug_Pools.Print_Info(Put_Line); -begin +@b{begin} Info (P); - A := new Integer; - B := new Integer; + A := @b{new} Integer; + B := @b{new} Integer; B := A; Info (P); Free (A); - begin - Put_Line (Integer'Image(B.all)); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; - begin + @b{begin} + Put_Line (Integer'Image(B.@b{all})); + @b{exception} + @b{when} E : @b{others} => Put_Line ("raised: " & Exception_Name (E)); + @b{end}; + @b{begin} Free (B); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; + @b{exception} + @b{when} E : @b{others} => Put_Line ("raised: " & Exception_Name (E)); + @b{end}; B := UC(A'Access); - begin - Put_Line (Integer'Image(B.all)); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; - begin + @b{begin} + Put_Line (Integer'Image(B.@b{all})); + @b{exception} + @b{when} E : @b{others} => Put_Line ("raised: " & Exception_Name (E)); + @b{end}; + @b{begin} Free (B); - exception - when E : others => Put_Line ("raised: " & Exception_Name (E)); - end; + @b{exception} + @b{when} E : @b{others} => Put_Line ("raised: " & Exception_Name (E)); + @b{end}; Info (P); -end Debug_Pool_Test; +@b{end} Debug_Pool_Test; @end smallexample @noindent @@ -18759,7 +18086,6 @@ Debug Pool info: High Water Mark: 8 @end smallexample -@ifclear vms @ifclear FSFEDITION @node The gnatmem Tool @section The @command{gnatmem} Tool @@ -18828,7 +18154,7 @@ $ gnatmake -g my_program -largs -lgmem As library @file{libgmem.a} contains an alternate body for package @code{System.Memory}, @file{s-memory.adb} should not be compiled and linked when an executable is linked with library @file{libgmem.a}. It is then not -recommended to use @command{gnatmake} with switch @option{^-a^/ALL_FILES^}. +recommended to use @command{gnatmake} with switch @option{-a}. @noindent When @file{my_program} is executed, the file @file{gmem.out} is produced. @@ -18958,34 +18284,34 @@ Suppose that we have the following Ada program: @smallexample @c ada @group @cartouche -with Unchecked_Deallocation; -procedure Test_Gm is +@b{with} Unchecked_Deallocation; +@b{procedure} Test_Gm @b{is} - type T is array (1..1000) of Integer; - type Ptr is access T; - procedure Free is new Unchecked_Deallocation (T, Ptr); + @b{type} T @b{is} @b{array} (1..1000) @b{of} Integer; + @b{type} Ptr @b{is} @b{access} T; + @b{procedure} Free @b{is} @b{new} Unchecked_Deallocation (T, Ptr); A : Ptr; - procedure My_Alloc is - begin - A := new T; - end My_Alloc; + @b{procedure} My_Alloc @b{is} + @b{begin} + A := @b{new} T; + @b{end} My_Alloc; - procedure My_DeAlloc is + @b{procedure} My_DeAlloc @b{is} B : Ptr := A; - begin + @b{begin} Free (B); - end My_DeAlloc; + @b{end} My_DeAlloc; -begin +@b{begin} My_Alloc; - for I in 1 .. 5 loop - for J in I .. 5 loop + @b{for} I @b{in} 1 .. 5 @b{loop} + @b{for} J @b{in} I .. 5 @b{loop} My_Alloc; - end loop; + @b{end} @b{loop}; My_Dealloc; - end loop; -end; + @b{end} @b{loop}; +@b{end}; @end cartouche @end group @end smallexample @@ -19120,7 +18446,6 @@ Allocation Root # 4 The allocation root #1 of the first example has been split in 2 roots #1 and #3 thanks to the more precise associated backtrace. @end ifclear -@end ifclear @node Stack Related Facilities @chapter Stack Related Facilities @@ -19176,7 +18501,6 @@ For the environment task, the stack size depends on system defaults and is unknown to the compiler. Stack checking may still work correctly if a fixed size stack is allocated, but this cannot be guaranteed. -@ifclear vms To ensure that a clean exception is signalled for stack overflow, set the environment variable @env{GNAT_STACK_LIMIT} to indicate the maximum @@ -19195,36 +18519,6 @@ of stack used by the environment task. If it is necessary to increase the amount of stack for the environment task, then this is an operating systems issue, and must be addressed with the appropriate operating systems commands. -@end ifclear -@ifset vms -To have a fixed size stack in the environment task, the stack must be put -in the P0 address space and its size specified. Use these switches to -create a p0 image: - -@smallexample -gnatmake my_progs -largs "-Wl,--opt=STACK=4000,/p0image" -@end smallexample - -@noindent -The quotes are required to keep case. The number after @samp{STACK=} is the -size of the environmental task stack in pagelets (512 bytes). In this example -the stack size is about 2 megabytes. - -@noindent -A consequence of the @option{/p0image} qualifier is also to makes RMS buffers -be placed in P0 space. Refer to @cite{HP OpenVMS Linker Utility Manual} for -more details about the @option{/p0image} qualifier and the @option{stack} -option. - -@noindent -On Itanium platforms, you can instead assign the @samp{GNAT_STACK_SIZE} and -@samp{GNAT_RBS_SIZE} logicals to the size of the primary and register -stack in kilobytes. For example: - -@smallexample -$ define GNAT_RBS_SIZE 1024 ! Limit the RBS size to 1MB. -@end smallexample -@end ifset @node Static Stack Usage Analysis @section Static Stack Usage Analysis @@ -19359,10 +18653,11 @@ For full details, refer to @cite{GNATcheck Reference Manual} document. @findex gnatstub @noindent -@command{gnatstub} creates body stubs, that is, empty but compilable bodies -for library unit declarations. +@command{gnatstub} creates empty but compilable bodies +for library unit declarations and empty but compilable +subunit for body stubs. -To create a body stub, @command{gnatstub} invokes the Ada +To create a body or a subunit, @command{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 information needed to compile the input source. To provide this information, @@ -19373,10 +18668,15 @@ Project Files}). Another possibility is to specify the source search path and needed configuration files in @option{-cargs} section of @command{gnatstub} call, see the description of the @command{gnatstub} switches below. -By default, all the program unit body stubs generated by @code{gnatstub} +If the @command{gnatstub} argument source contains preprocessing directives +then the needed options should be provided to run preprocessor as a part of +the @command{gnatstub} call, and the generated body stub will correspond to +the preprocessed source. + +By default, all the program unit bodies generated by @code{gnatstub} raise the predefined @code{Program_Error} exception, which will catch accidental calls of generated stubs. This behavior can be changed with -option @option{^--no-exception^/NO_EXCEPTION^} (see below). +option @option{--no-exception} (see below). @menu * Running gnatstub:: @@ -19390,9 +18690,9 @@ option @option{^--no-exception^/NO_EXCEPTION^} (see below). @command{gnatstub} has a command-line interface of the form: @smallexample -@c $ gnatstub @ovar{switches} @var{filename} @ovar{directory} +@c $ gnatstub @ovar{switches} @var{filename} @c Expanding @ovar macro inline (explanation in macro def comments) -$ gnatstub @r{[}@var{switches}@r{]} @var{filename} @r{[}@var{directory}@r{]} @r{[}-cargs @var{gcc_switches}@r{]} +$ gnatstub @r{[}@var{switches}@r{]} @var{filename} @r{[}-cargs @var{gcc_switches}@r{]} @end smallexample @noindent @@ -19400,30 +18700,26 @@ where @table @var @item filename is the name of the source file that contains a library unit declaration -for which a body must be created. The file name may contain the path -information. -The file name does not have to follow the GNAT file name conventions. If the -name -does not follow GNAT file naming conventions, the name of the body file must +for which a body must be created or a library unit body for which subunits +must be created for the body stubs declared in this body. +The file name may contain the path information. +If the name does not follow GNAT file naming conventions and a set +of seitches does not contain a project file that defines naming +conventions, the name of the body file must be provided -explicitly as the value of the @option{^-o^/BODY=^@var{body-name}} option. +explicitly as the value of the @option{-o@var{body-name}} option. If the file name follows the GNAT file naming conventions and the name of the body file is not provided, @command{gnatstub} -creates the name -of the body file from the argument file name by replacing the @file{.ads} -suffix -with the @file{.adb} suffix. - -@item directory -indicates the directory in which the body stub is to be placed (the default -is the -current directory) +takes the naming conventions for the generated source from the +project file provided as a parameter of @option{-P} switch if any, +or creates the name file to generate using the standard GNAT +naming conventions. @item @samp{@var{gcc_switches}} is a list of switches for @command{gcc}. They will be passed on to all compiler invocations made by @command{gnatstub} to generate the ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +@option{-I} switches to form the source search path, use the @option{-gnatec} switch to set the configuration file, use the @option{-gnat05} switch if sources should be compiled in Ada 2005 mode etc. @@ -19457,93 +18753,96 @@ Indicates that external variable @var{name} in the argument project has the value @var{value}. Has no effect if no project is specified as tool argument. -@item ^-f^/FULL^ -@cindex @option{^-f^/FULL^} (@command{gnatstub}) +@item --subunits +@cindex @option{--subunits} (@command{gnatstub}) +Generate subunits for body stubs. If this switch is specified, +@command{gnatstub} expects a library unit body as an agrument file, +otherwise a library unit declaration is expected. If a body stub +already has a corresponding subunit, @command{gnatstub} does not +generate anything for it. + +@item -f +@cindex @option{-f} (@command{gnatstub}) If the destination directory already contains a file with the name of the body file for the argument spec file, replace it with the generated body stub. +This switch cannot be used together with @option{--subunits}. -@item ^-hs^/HEADER=SPEC^ -@cindex @option{^-hs^/HEADER=SPEC^} (@command{gnatstub}) +@item -hs +@cindex @option{-hs} (@command{gnatstub}) Put the comment header (i.e., all the comments preceding the compilation unit) from the source of the library unit declaration into the body stub. -@item ^-hg^/HEADER=GENERAL^ -@cindex @option{^-hg^/HEADER=GENERAL^} (@command{gnatstub}) +@item -hg +@cindex @option{-hg} (@command{gnatstub}) Put a sample comment header into the body stub. -@item ^--header-file=@var{filename}^/FROM_HEADER_FILE=@var{filename}^ -@cindex @option{^--header-file^/FROM_HEADER_FILE=^} (@command{gnatstub}) +@item --header-file=@var{filename} +@cindex @option{--header-file} (@command{gnatstub}) Use the content of the file as the comment header for a generated body stub. -@ifclear vms @item -IDIR @cindex @option{-IDIR} (@command{gnatstub}) @itemx -I- @cindex @option{-I-} (@command{gnatstub}) -@end ifclear -@ifset vms -@item /NOCURRENT_DIRECTORY -@cindex @option{/NOCURRENT_DIRECTORY} (@command{gnatstub}) -@end ifset -^These switches have ^This switch has^ the same meaning as in calls to +These switches have the same meaning as in calls to @command{gcc}. -^They define ^It defines ^ the source search path in the call to +They define the source search path in the call to @command{gcc} issued by @command{gnatstub} to compile an argument source file. -@item ^-gnatec^/CONFIGURATION_PRAGMAS_FILE=^@var{PATH} -@cindex @option{^-gnatec^/CONFIGURATION_PRAGMAS_FILE^} (@command{gnatstub}) +@item -gnatec@var{PATH} +@cindex @option{-gnatec} (@command{gnatstub}) This switch has the same meaning as in calls to @command{gcc}. It defines the additional configuration file to be passed to the call to @command{gcc} issued by @command{gnatstub} to compile an argument source file. -@item ^-gnatyM^/MAX_LINE_LENGTH=^@var{n} -@cindex @option{^-gnatyM^/MAX_LINE_LENGTH^} (@command{gnatstub}) +@item -gnatyM@var{n} +@cindex @option{-gnatyM} (@command{gnatstub}) (@var{n} is a non-negative integer). Set the maximum line length that is allowed in a source file. The default is 79. The maximum value that can be specified is 32767. Note that in the special case of configuration pragma files, the maximum is always 32767 regardless of whether or not this switch appears. -@item ^-gnaty^/STYLE_CHECKS=^@var{n} -@cindex @option{^-gnaty^/STYLE_CHECKS=^} (@command{gnatstub}) +@item -gnaty@var{n} +@cindex @option{-gnaty} (@command{gnatstub}) (@var{n} is a non-negative integer from 1 to 9). Set the indentation level in the generated body sample to @var{n}. The default indentation is 3. -@item ^-gnatyo^/ORDERED_SUBPROGRAMS^ -@cindex @option{^-gnatyo^/ORDERED_SUBPROGRAMS^} (@command{gnatstub}) +@item -gnatyo +@cindex @option{-gnatyo} (@command{gnatstub}) Order local bodies alphabetically. (By default local bodies are ordered in the same way as the corresponding local specs in the argument spec file.) -@item ^-i^/INDENTATION=^@var{n} -@cindex @option{^-i^/INDENTATION^} (@command{gnatstub}) -Same as @option{^-gnaty^/STYLE_CHECKS=^@var{n}} +@item -i@var{n} +@cindex @option{-i} (@command{gnatstub}) +Same as @option{-gnaty@var{n}} -@item ^-k^/TREE_FILE=SAVE^ -@cindex @option{^-k^/TREE_FILE=SAVE^} (@command{gnatstub}) +@item -k +@cindex @option{-k} (@command{gnatstub}) Do not remove the tree file (i.e., the snapshot of the compiler internal structures used by @command{gnatstub}) after creating the body stub. -@item ^-l^/LINE_LENGTH=^@var{n} -@cindex @option{^-l^/LINE_LENGTH^} (@command{gnatstub}) -Same as @option{^-gnatyM^/MAX_LINE_LENGTH=^@var{n}} +@item -l@var{n} +@cindex @option{-l} (@command{gnatstub}) +Same as @option{-gnatyM@var{n}} -@item ^--no-exception^/NO_EXCEPTION^ -@cindex @option{^--no-exception^/NO_EXCEPTION^} (@command{gnatstub}) +@item --no-exception +@cindex @option{--no-exception} (@command{gnatstub}) Avoid raising PROGRAM_ERROR in the generated bodies of program unit stubs. This is not always possible for function stubs. -@item ^--no-local-header^/NO_LOCAL_HEADER^ -@cindex @option{^--no-local-header^/NO_LOCAL_HEADER^} (@command{gnatstub}) +@item --no-local-header +@cindex @option{--no-local-header} (@command{gnatstub}) Do not place local comment header with unit name before body stub for a unit. -@item ^-o ^/BODY=^@var{body-name} -@cindex @option{^-o^/BODY^} (@command{gnatstub}) +@item -o @var{body-name} +@cindex @option{-o} (@command{gnatstub}) Body file name. This should be set if the argument file name does not follow the GNAT file naming @@ -19551,50 +18850,57 @@ conventions. If this switch is omitted the default name for the body will be obtained from the argument file name according to the GNAT file naming conventions. -@item ^-W^/RESULT_ENCODING=^@var{e} -@cindex @option{^-W^/RESULT_ENCODING=^} (@command{gnatstub}) +@item --dir=@var{dir-name} +@cindex @option{--dir} (@command{gnatstub}) +The path to the directory to place the generated files into. +If this switch is not set, the generated library unit body is +placed in the current directory, and generated sununits - +in the directory where the argument body is located. + +@item -W@var{e} +@cindex @option{-W} (@command{gnatstub}) Specify the wide character encoding method for the output body file. @var{e} is one of the following: @itemize @bullet -@item ^h^HEX^ +@item h Hex encoding -@item ^u^UPPER^ +@item u Upper half encoding -@item ^s^SHIFT_JIS^ +@item s Shift/JIS encoding -@item ^e^EUC^ +@item e EUC encoding -@item ^8^UTF8^ +@item 8 UTF-8 encoding -@item ^b^BRACKETS^ +@item b Brackets encoding (default value) @end itemize -@item ^-q^/QUIET^ -@cindex @option{^-q^/QUIET^} (@command{gnatstub}) +@item -q +@cindex @option{-q} (@command{gnatstub}) Quiet mode: do not generate a confirmation when a body is successfully created, and do not generate a message when a body is not required for an argument unit. -@item ^-r^/TREE_FILE=REUSE^ -@cindex @option{^-r^/TREE_FILE=REUSE^} (@command{gnatstub}) +@item -r +@cindex @option{-r} (@command{gnatstub}) Reuse the tree file (if it exists) instead of creating it. Instead of creating the tree file for the library unit declaration, @command{gnatstub} tries to find it in the current directory and use it for creating a body. If the tree file is not found, no body is created. This option -also implies @option{^-k^/SAVE^}, whether or not +also implies @option{-k}, whether or not the latter is set explicitly. -@item ^-t^/TREE_FILE=OVERWRITE^ -@cindex @option{^-t^/TREE_FILE=OVERWRITE^} (@command{gnatstub}) +@item -t +@cindex @option{-t} (@command{gnatstub}) Overwrite the existing tree file. If the current directory already contains the file which, according to the GNAT file naming rules should be considered as a tree file for the argument source file, @@ -19602,8 +18908,8 @@ be considered as a tree file for the argument source file, will refuse to create the tree file needed to create a sample body unless this option is set. -@item ^-v^/VERBOSE^ -@cindex @option{^-v^/VERBOSE^} (@command{gnatstub}) +@item -v +@cindex @option{-v} (@command{gnatstub}) Verbose mode: generate version information. @end table @@ -19647,9 +18953,8 @@ is installed at its default location. * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: -@ifclear vms +* Putting Tests under Version Control:: * Support for other platforms/run-times:: -@end ifclear * Current Limitations:: @end menu @@ -19683,7 +18988,7 @@ path. is a list of switches for @command{gcc}. These switches will be passed on to all compiler invocations made by @command{gnattest} to generate a set of ASIS trees. Here you can provide -@option{^-I^/INCLUDE_DIRS=^} switches to form the source search path, +@option{-I} switches to form the source search path, use the @option{-gnatec} switch to set the configuration file, use the @option{-gnat05} switch if sources should be compiled in Ada 2005 mode, etc. @@ -19719,9 +19024,9 @@ doesn't exist already. By default, those separate test files are located in a "gnattest/tests" directory that is created in the object directory of corresponding project file. For example, if a source file my_unit.ads in directory src contains a visible subprogram Proc, then the corresponding unit -test will be found in file src/tests/my_unit-test_data-tests-proc_.adb. - is a signature encoding used to differentiate test names in case of -overloading. +test will be found in file src/tests/my_unit-test_data-tests.adb and will be +called Test_Proc_. is a signature encoding used to differentiate +test names in case of overloading. Note that if the project already has both my_unit.ads and my_unit-test_data.ads, this will cause a name conflict with the generated test package. @@ -19757,7 +19062,9 @@ Suppresses noncritical output messages. @item -v @cindex @option{-v} (@command{gnattest}) -Verbose mode: generates version information. +Verbose mode: generates version information if specified by itself on the +command line. If specified via GNATtest_Switches, produces output +about the execution of the tool. @item --validate-type-extensions @cindex @option{--validate-type-extensions} (@command{gnattest}) @@ -19770,15 +19077,21 @@ Specifies the default behavior of generated skeletons. @var{val} can be either "fail" or "pass", "fail" being the default. @item --passed-tests=@var{val} -@cindex @option{--skeleton-default} (@command{gnattest}) +@cindex @option{--passed-tests} (@command{gnattest}) Specifies whether or not passed tests should be shown. @var{val} can be either "show" or "hide", "show" being the default. +@item --exit-status=@var{val} +@cindex @option{--exit-status} (@command{gnattest}) +Specifies whether or not generated test driver should return failure exit +status if at least one test fails or crashes. @var{val} can be either +"on" or "off", "off" being the default. + @item --tests-root=@var{dirname} @cindex @option{--tests-root} (@command{gnattest}) -The directory hierarchy of tested sources is recreated in the @var{dirname} -directory, and test packages are placed in corresponding directories. +The hierarchy of source directories, if any, is recreated in the @var{dirname} +directory, with test packages placed in directories corresponding to those of the sources. If the @var{dirname} is a relative path, it is considered relative to the object directory of the project file. When all sources from all projects are taken recursively from all projects, directory hierarchies of tested sources are @@ -19787,7 +19100,10 @@ placed accordingly. @item --subdir=@var{dirname} @cindex @option{--subdir} (@command{gnattest}) -Test packages are placed in subdirectories. +Test packages are placed in a subdirectory of the corresponding source directory, +with the name @var{dirname}. Thus, each set of unit tests is located in a subdirectory of the +code under test. If the sources are in separate directories, each source directory +has a test subdirectory named @var{dirname}. @item --tests-dir=@var{dirname} @cindex @option{--tests-dir} (@command{gnattest}) @@ -19821,6 +19137,15 @@ separates. Note that if separate test routines had any manually added with clauses they will be moved to the test package body as is and have to be moved by hand. +@item --omit-sloc +@cindex @option{--omit-sloc} (@command{gnattest}) +Suppresses comment line containing file name and line number of corresponding +subprograms in test skeletons. + +@item --test-duration +@cindex @option{--test-duration} (@command{gnattest}) +Adds time measurements for each test in generated test driver. + @end table @option{--tests_root}, @option{--subdir} and @option{--tests-dir} switches are @@ -20191,7 +19516,20 @@ gnatmake -Pmixing/test_driver.gpr mixing/test_runner @end smallexample -@ifclear vms +@node Putting Tests under Version Control +@section Putting Tests under Version Control + +@noindent +As has been stated earlier, @command{gnattest} generates two different types +of code, test skeletons and harness. The harness is generated completely +automatically each time, does not require manual changes and therefore should +not be put under version control. +It makes sense to put under version control files containing test data packages, +both specs and bodies, and files containing bodies of test packages. Note that +test package specs are also generated automatically each time and should not be +put under version control. +Option @option{--omit-sloc} may be usefull when putting test packages under VCS. + @node Support for other platforms/run-times @section Support for other platforms/run-times @@ -20212,7 +19550,6 @@ the ZFP run-time library: @smallexample powerpc-elf-gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp @end smallexample -@end ifclear @node Current Limitations @section Current Limitations @@ -20222,7 +19559,7 @@ powerpc-elf-gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp The tool currently does not support following features: @itemize @bullet -@item generic tests for generic packages and package instantiations +@item generic tests for nested generic packages and their instantiations @item tests for protected subprograms and entries @end itemize @@ -20269,8 +19606,8 @@ package, in file @file{s-dimmks.ads}. @smallexample @c ada @group - type Mks_Type is new Long_Long_Float - with + @b{type} Mks_Type @b{is} @b{new} Long_Long_Float + @b{with} Dimension_System => ( (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), @@ -20288,9 +19625,9 @@ conventional units. For example: @smallexample @c ada @group - subtype Length is Mks_Type - with - Dimension => (Symbol => 'm', Meter => 1, others => 0); + @b{subtype} Length @b{is} Mks_Type + @b{with} + Dimension => (Symbol => 'm', Meter => 1, @b{others} => 0); @end group @end smallexample @@ -20304,10 +19641,10 @@ example: @smallexample @c ada @group - m : constant Length := 1.0; - kg : constant Mass := 1.0; - s : constant Time := 1.0; - A : constant Electric_Current := 1.0; + m : @b{constant} Length := 1.0; + kg : @b{constant} Mass := 1.0; + s : @b{constant} Time := 1.0; + A : @b{constant} Electric_Current := 1.0; @end group @end smallexample @@ -20316,10 +19653,10 @@ as well as useful multiples of these units: @smallexample @c ada @group - cm : constant Length := 1.0E-02; - g : constant Mass := 1.0E-03; - min : constant Time := 60.0; - day : constant Time := 60.0 * 24.0 * min; + cm : @b{constant} Length := 1.0E-02; + g : @b{constant} Mass := 1.0E-03; + min : @b{constant} Time := 60.0; + day : @b{constant} Time := 60.0 * 24.0 * min; ... @end group @end smallexample @@ -20332,11 +19669,11 @@ be used for output of a value of that unit: @smallexample @c ada @group - subtype Acceleration is Mks_Type - with Dimension => ("m/sec^^^2", + @b{subtype} Acceleration @b{is} Mks_Type + @b{with} Dimension => ("m/sec^2", Meter => 1, Second => -2, - others => 0); + @b{others} => 0); @end group @end smallexample @@ -20345,25 +19682,25 @@ Here is a complete example of use: @smallexample @c ada @group -with System.Dim.MKS; use System.Dim.Mks; -with System.Dim.Mks_IO; use System.Dim.Mks_IO; -with Text_IO; use Text_IO; -procedure Free_Fall is - subtype Acceleration is Mks_Type - with Dimension => ("m/sec^^^2", 1, 0, -2, others => 0); - G : constant acceleration := 9.81 * m / (s ** 2); +@b{with} System.Dim.MKS; @b{use} System.Dim.Mks; +@b{with} System.Dim.Mks_IO; @b{use} System.Dim.Mks_IO; +@b{with} Text_IO; @b{use} Text_IO; +@b{procedure} Free_Fall @b{is} + @b{subtype} Acceleration @b{is} Mks_Type + @b{with} Dimension => ("m/sec^2", 1, 0, -2, @b{others} => 0); + G : @b{constant} acceleration := 9.81 * m / (s ** 2); T : Time := 10.0*s; Distance : Length; @end group @group -begin +@b{begin} Put ("Gravitational constant: "); Put (G, Aft => 2, Exp => 0); Put_Line (""); Distance := 0.5 * G * T ** 2; Put ("distance travelled in 10 seconds of free fall "); Put (Distance, Aft => 2, Exp => 0); Put_Line (""); -end Free_Fall; +@b{end} Free_Fall; @end group @end smallexample @@ -20371,7 +19708,7 @@ end Free_Fall; Execution of this program yields: @smallexample @group -Gravitational constant: 9.81 m/sec^^^2 +Gravitational constant: 9.81 m/sec^2 distance travelled in 10 seconds of free fall 490.50 m @end group @end smallexample @@ -20605,54 +19942,54 @@ The corresponding Ada code is generated: @smallexample @c ada @group @cartouche - package Class_Carnivore is - type Carnivore is limited interface; - pragma Import (CPP, Carnivore); - - function Number_Of_Teeth (this : access Carnivore) return int is abstract; - end; - use Class_Carnivore; - - package Class_Domestic is - type Domestic is limited interface; - pragma Import (CPP, Domestic); - - procedure Set_Owner - (this : access Domestic; - Name : Interfaces.C.Strings.chars_ptr) is abstract; - end; - use Class_Domestic; - - package Class_Animal is - type Animal is tagged limited record - Age_Count : aliased int; - end record; - pragma Import (CPP, Animal); - - procedure Set_Age (this : access Animal; New_Age : int); - pragma Import (CPP, Set_Age, "_ZN6Animal7Set_AgeEi"); - end; - use Class_Animal; - - package Class_Dog is - type Dog is new Animal and Carnivore and Domestic with record - Tooth_Count : aliased int; + @b{package} Class_Carnivore @b{is} + @b{type} Carnivore @b{is} @b{limited} interface; + @b{pragma} Import (CPP, Carnivore); + + @b{function} Number_Of_Teeth (this : @b{access} Carnivore) @b{return} int @b{is} @b{abstract}; + @b{end}; + @b{use} Class_Carnivore; + + @b{package} Class_Domestic @b{is} + @b{type} Domestic @b{is} @b{limited} interface; + @b{pragma} Import (CPP, Domestic); + + @b{procedure} Set_Owner + (this : @b{access} Domestic; + Name : Interfaces.C.Strings.chars_ptr) @b{is} @b{abstract}; + @b{end}; + @b{use} Class_Domestic; + + @b{package} Class_Animal @b{is} + @b{type} Animal @b{is} @b{tagged} @b{limited} @b{record} + Age_Count : @b{aliased} int; + @b{end} @b{record}; + @b{pragma} Import (CPP, Animal); + + @b{procedure} Set_Age (this : @b{access} Animal; New_Age : int); + @b{pragma} Import (CPP, Set_Age, "_ZN6Animal7Set_AgeEi"); + @b{end}; + @b{use} Class_Animal; + + @b{package} Class_Dog @b{is} + @b{type} Dog @b{is} @b{new} Animal @b{and} Carnivore @b{and} Domestic @b{with} @b{record} + Tooth_Count : @b{aliased} int; Owner : Interfaces.C.Strings.chars_ptr; - end record; - pragma Import (CPP, Dog); + @b{end} @b{record}; + @b{pragma} Import (CPP, Dog); - function Number_Of_Teeth (this : access Dog) return int; - pragma Import (CPP, Number_Of_Teeth, "_ZN3Dog15Number_Of_TeethEv"); + @b{function} Number_Of_Teeth (this : @b{access} Dog) @b{return} int; + @b{pragma} Import (CPP, Number_Of_Teeth, "_ZN3Dog15Number_Of_TeethEv"); - procedure Set_Owner - (this : access Dog; Name : Interfaces.C.Strings.chars_ptr); - pragma Import (CPP, Set_Owner, "_ZN3Dog9Set_OwnerEPc"); + @b{procedure} Set_Owner + (this : @b{access} Dog; Name : Interfaces.C.Strings.chars_ptr); + @b{pragma} Import (CPP, Set_Owner, "_ZN3Dog9Set_OwnerEPc"); - function New_Dog return Dog; - pragma CPP_Constructor (New_Dog); - pragma Import (CPP, New_Dog, "_ZN3DogC1Ev"); - end; - use Class_Dog; + @b{function} New_Dog @b{return} Dog; + @b{pragma} CPP_Constructor (New_Dog); + @b{pragma} Import (CPP, New_Dog, "_ZN3DogC1Ev"); + @b{end}; + @b{use} Class_Dog; @end cartouche @end group @end smallexample @@ -20693,10 +20030,6 @@ environment. * The External Symbol Naming Scheme of GNAT:: * Converting Ada Files to html with gnathtml:: * Installing gnathtml:: -@ifset vms -* LSE:: -* Profiling:: -@end ifset @end menu @node Using Other Utility Programs with GNAT @@ -20708,12 +20041,10 @@ particular the debugging information uses this format. This means programs generated by GNAT can be used with existing utilities that depend on these formats. -@ifclear vms In general, any utility program that works with C will also often work with Ada programs generated by GNAT. This includes software utilities such as gprof (a profiling program), @code{gdb} (the FSF debugger), and utilities such as Purify. -@end ifclear @node The External Symbol Naming Scheme of GNAT @section The External Symbol Naming Scheme of GNAT @@ -20732,9 +20063,9 @@ we have the following package spec: @smallexample @c ada @group @cartouche -package QRS is +@b{package} QRS @b{is} MN : Integer; -end QRS; +@b{end} QRS; @end cartouche @end group @end smallexample @@ -20748,12 +20079,12 @@ Of course if a @code{pragma Export} is used this may be overridden: @smallexample @c ada @group @cartouche -package Exports is +@b{package} Exports @b{is} Var1 : Integer; - pragma Export (Var1, C, External_Name => "var1_name"); + @b{pragma} Export (Var1, C, External_Name => "var1_name"); Var2 : Integer; - pragma Export (Var2, C, Link_Name => "var2_link_name"); -end Exports; + @b{pragma} Export (Var2, C, Link_Name => "var2_link_name"); +@b{end} Exports; @end cartouche @end group @end smallexample @@ -20778,7 +20109,7 @@ names. So if we have a library level procedure such as @smallexample @c ada @group @cartouche -procedure Hello (S : String); +@b{procedure} Hello (S : String); @end cartouche @end group @end smallexample @@ -20803,9 +20134,9 @@ be able to click on any identifier and go to its declaration. The command line is as follow: @smallexample -@c $ perl gnathtml.pl @ovar{^switches^options^} @var{ada-files} +@c $ perl gnathtml.pl @ovar{switches} @var{ada-files} @c Expanding @ovar macro inline (explanation in macro def comments) -$ perl gnathtml.pl @r{[}@var{^switches^options^}@r{]} @var{ada-files} +$ perl gnathtml.pl @r{[}@var{switches}@r{]} @var{ada-files} @end smallexample @noindent @@ -20813,7 +20144,7 @@ You can pass it as many Ada files as you want. @code{gnathtml} will generate an html file for every ada file, and a global file called @file{index.htm}. This file is an index of every identifier defined in the files. -The available ^switches^options^ are the following ones: +The available switches are the following ones: @table @option @item -83 @@ -20851,7 +20182,7 @@ entities too. @item -l @var{number} @cindex @option{-l} (@code{gnathtml}) -If this ^switch^option^ is provided and @var{number} is not 0, then +If this switch is provided and @var{number} is not 0, then @code{gnathtml} will number the html files every @var{number} line. @item -I @var{dir} @@ -20872,19 +20203,19 @@ a full Integrated Development Environment for compiling, checking, running and debugging applications, you may use @file{.gpr} files to give the directories where Emacs can find sources and object files. -Using this ^switch^option^, you can tell gnathtml to use these files. +Using this switch, you can tell gnathtml to use these files. This allows you to get an html version of your application, even if it is spread over multiple directories. @item -sc @var{color} @cindex @option{-sc} (@code{gnathtml}) -This ^switch^option^ allows you to change the color used for symbol +This switch allows you to change the color used for symbol definitions. The default value is red. The color argument can be any name accepted by html. @item -t @var{file} @cindex @option{-t} (@code{gnathtml}) -This ^switch^option^ provides the name of a file. This file contains a list of +This switch provides the name of a file. This file contains a list of file names to be converted, and the effect is exactly as though they had appeared explicitly on the command line. This is the recommended way to work around the command line length limit on some @@ -20916,34 +20247,7 @@ Alternatively, you may run the script using the following command line: $ perl gnathtml.pl @r{[}@var{switches}@r{]} @var{files} @end smallexample -@ifset vms -@node LSE -@section LSE -@findex LSE -@noindent -The GNAT distribution provides an Ada 95 template for the HP Language -Sensitive Editor (LSE), a component of DECset. In order to -access it, invoke LSE with the qualifier /ENVIRONMENT=GNU:[LIB]ADA95.ENV. - -@node Profiling -@section Profiling -@findex PCA - -@noindent -GNAT supports The HP Performance Coverage Analyzer (PCA), a component -of DECset. To use it proceed as outlined under ``HELP PCA'', except for running -the collection phase with the /DEBUG qualifier. - -@smallexample -$ GNAT MAKE /DEBUG -$ DEFINE LIB$DEBUG PCA$COLLECTOR -$ RUN/DEBUG -@end smallexample -@noindent -@end ifset - -@ifclear vms @c ****************************** @node Code Coverage and Profiling @chapter Code Coverage and Profiling @@ -21152,12 +20456,12 @@ gprof my_prog The complete form of the gprof command line is the following: @smallexample -gprof [^switches^options^] [executable [data-file]] +gprof [switches] [executable [data-file]] @end smallexample @noindent -@code{gprof} supports numerous ^switch^options^. The order of these -^switch^options^ does not matter. The full list of options can be found in +@code{gprof} supports numerous switch. The order of these +switch does not matter. The full list of options can be found in the GNU Profiler User's Guide documentation that comes with this documentation. The following is the subset of those switches that is most relevant: @@ -21228,7 +20532,6 @@ time-consuming functions. The call graph shows, for each subprogram, the subprograms that call it, and the subprograms that it calls. It also provides an estimate of the time spent in each of those callers/called subprograms. -@end ifclear @c ****************************** @node Running and Debugging Ada Programs @@ -21237,11 +20540,6 @@ spent in each of those callers/called subprograms. @noindent This chapter discusses how to debug Ada programs. -@ifset vms -It applies to GNAT on the Alpha OpenVMS platform; -for I64 OpenVMS please refer to the @cite{OpenVMS Debugger Manual}, -since HP has implemented Ada support in the OpenVMS debugger on I64. -@end ifset An incorrect Ada program may be handled in three ways by the GNAT compiler: @@ -21294,9 +20592,6 @@ GNAT. The latest versions of @code{GDB} are Ada-aware and can handle complex Ada data structures. @xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, -@ifset vms -located in the GNU:[DOCS] directory, -@end ifset for full details on the usage of @code{GDB}, including a section on its usage on programs. This manual should be consulted for full details. The section that follows is a brief introduction to the @@ -21309,7 +20604,7 @@ separate from the generated code. It makes the object files considerably larger, but it does not add to the size of the actual executable that will be loaded into memory, and has no impact on run-time performance. The generation of debug information is triggered by the use of the -^-g^/DEBUG^ switch in the @command{gcc} or @command{gnatmake} command +-g switch in the @command{gcc} or @command{gnatmake} command used to carry out the compilations. It is important to emphasize that the use of these options does not change the generated code. @@ -21352,21 +20647,19 @@ This section describes how to initiate the debugger. @c clumsy to get the first paragraph nonindented given the conditional @c nature of the description -@ifclear vms The debugger can be launched from a @code{GPS} menu or directly from the command line. The description below covers the latter use. All the commands shown can be used in the @code{GPS} debug console window, but there are usually more GUI-based ways to achieve the same effect. -@end ifclear The command to run @code{GDB} is @smallexample -$ ^gdb program^GDB PROGRAM^ +$ gdb program @end smallexample @noindent -where @code{^program^PROGRAM^} is the name of the executable file. This +where @code{program} is the name of the executable file. This activates the debugger and results in a prompt for debugger commands. The simplest command is simply @code{run}, which causes the program to run exactly as if the debugger were not present. The following section @@ -21379,9 +20672,6 @@ describes some of the additional commands that can be given to @code{GDB}. @noindent @code{GDB} contains a large repertoire of commands. @xref{Top,, Debugging with GDB, gdb, Debugging with GDB}, -@ifset vms -located in the GNU:[DOCS] directory, -@end ifset for extensive documentation on the use of these commands, together with examples of their use. Furthermore, the command @command{help} invoked from within GDB activates a simple help @@ -21704,30 +20994,30 @@ a generic, by using the appropriate expanded names. For example, if we have @smallexample @c ada @group @cartouche -procedure g is +@b{procedure} g @b{is} - generic package k is - procedure kp (v1 : in out integer); - end k; + @b{generic} @b{package} k @b{is} + @b{procedure} kp (v1 : @b{in} @b{out} integer); + @b{end} k; - package body k is - procedure kp (v1 : in out integer) is - begin + @b{package} @b{body} k @b{is} + @b{procedure} kp (v1 : @b{in} @b{out} integer) @b{is} + @b{begin} v1 := v1 + 1; - end kp; - end k; + @b{end} kp; + @b{end} k; - package k1 is new k; - package k2 is new k; + @b{package} k1 @b{is} @b{new} k; + @b{package} k2 @b{is} @b{new} k; var : integer := 1; -begin +@b{begin} k1.kp (var); k2.kp (var); k1.kp (var); k2.kp (var); -end; +@b{end}; @end cartouche @end group @end smallexample @@ -21826,7 +21116,7 @@ terminates prematurely or goes into an infinite loop, the last error message displayed may help to pinpoint the culprit. @item -Run @command{gcc} with the @option{^-v (verbose)^/VERBOSE^} switch. In this +Run @command{gcc} with the @option{-v (verbose)} switch. In this mode, @command{gcc} produces ongoing information about the progress of the compilation and provides the name of each procedure as code is generated. This switch allows you to find which Ada procedure was being @@ -21835,7 +21125,7 @@ compiled when it encountered a code generation problem. @item @cindex @option{-gnatdc} switch Run @command{gcc} with the @option{-gnatdc} switch. This is a GNAT specific -switch that does for the front-end what @option{^-v^VERBOSE^} does +switch that does for the front-end what @option{-v} does for the back end. The system prints the name of each unit, either a compilation unit or nested unit, as it is being analyzed. @item @@ -21860,15 +21150,15 @@ brief description of its organization may be helpful: @itemize @bullet @item -Files with prefix @file{^sc^SC^} contain the lexical scanner. +Files with prefix @file{sc} contain the lexical scanner. @item -All files prefixed with @file{^par^PAR^} are components of the parser. The +All files prefixed with @file{par} are components of the parser. The numbers correspond to chapters of the Ada Reference Manual. For example, parsing of select statements can be found in @file{par-ch9.adb}. @item -All files prefixed with @file{^sem^SEM^} perform semantic analysis. The +All files prefixed with @file{sem} perform semantic analysis. The numbers correspond to chapters of the Ada standard. For example, all issues involving context clauses can be found in @file{sem_ch10.adb}. In addition, some features of the language require sufficient special processing @@ -21876,14 +21166,14 @@ to justify their own semantic files: sem_aggr for aggregates, sem_disp for dynamic dispatching, etc. @item -All files prefixed with @file{^exp^EXP^} perform normalization and +All files prefixed with @file{exp} perform normalization and expansion of the intermediate representation (abstract syntax tree, or AST). these files use the same numbering scheme as the parser and semantics files. For example, the construction of record initialization procedures is done in @file{exp_ch3.adb}. @item -The files prefixed with @file{^bind^BIND^} implement the binder, which +The files prefixed with @file{bind} implement the binder, which verifies the consistency of the compilation, determines an order of elaboration, and generates the bind file. @@ -21901,28 +21191,28 @@ all entities, computed during semantic analysis. @item Library management issues are dealt with in files with prefix -@file{^lib^LIB^}. +@file{lib}. @item @findex Ada @cindex Annex A -Ada files with the prefix @file{^a-^A-^} are children of @code{Ada}, as +Ada files with the prefix @file{a-} are children of @code{Ada}, as defined in Annex A. @item @findex Interfaces @cindex Annex B -Files with prefix @file{^i-^I-^} are children of @code{Interfaces}, as +Files with prefix @file{i-} are children of @code{Interfaces}, as defined in Annex B. @item @findex System -Files with prefix @file{^s-^S-^} are children of @code{System}. This includes +Files with prefix @file{s-} are children of @code{System}. This includes both language-defined children and GNAT run-time routines. @item @findex GNAT -Files with prefix @file{^g-^G-^} are children of @code{GNAT}. These are useful +Files with prefix @file{g-} are children of @code{GNAT}. These are useful general-purpose packages, fully documented in their specs. All the other @file{.c} files are modifications of common @command{gcc} files. @end itemize @@ -22004,21 +21294,21 @@ Here is a simple example: @smallexample @c ada @cartouche -procedure STB is +@b{procedure} STB @b{is} - procedure P1 is - begin - raise Constraint_Error; - end P1; + @b{procedure} P1 @b{is} + @b{begin} + @b{raise} Constraint_Error; + @b{end} P1; - procedure P2 is - begin + @b{procedure} P2 @b{is} + @b{begin} P1; - end P2; + @b{end} P2; -begin +@b{begin} P2; -end STB; +@b{end} STB; @end cartouche @end smallexample @@ -22101,11 +21391,9 @@ in the stack traceback: @smallexample $ gdb -nw stb -@ifclear vms @noindent Furthermore, this feature is not implemented inside Windows DLL. Only the non-symbolic traceback is reported in this case. -@end ifclear (gdb) break *0x401373 Breakpoint 1 at 0x401373: file stb.adb, line 5. @@ -22129,31 +21417,31 @@ be retrieved in an exception handler within the Ada program, by means of the Ada facilities defined in @code{Ada.Exceptions}. Here is a simple example: @smallexample @c ada -with Ada.Text_IO; -with Ada.Exceptions; +@b{with} Ada.Text_IO; +@b{with} Ada.Exceptions; -procedure STB is +@b{procedure} STB @b{is} - use Ada; - use Ada.Exceptions; + @b{use} Ada; + @b{use} Ada.Exceptions; - procedure P1 is + @b{procedure} P1 @b{is} K : Positive := 1; - begin + @b{begin} K := K - 1; - exception - when E : others => + @b{exception} + @b{when} E : @b{others} => Text_IO.Put_Line (Exception_Information (E)); - end P1; + @b{end} P1; - procedure P2 is - begin + @b{procedure} P2 @b{is} + @b{begin} P1; - end P2; + @b{end} P2; -begin +@b{begin} P2; -end STB; +@b{end} STB; @end smallexample @noindent @@ -22186,42 +21474,42 @@ the program, and we display it using @code{GNAT.Debug_Utilities.Image} to convert addresses to strings: @smallexample @c ada -with Ada.Text_IO; -with GNAT.Traceback; -with GNAT.Debug_Utilities; +@b{with} Ada.Text_IO; +@b{with} GNAT.Traceback; +@b{with} GNAT.Debug_Utilities; -procedure STB is +@b{procedure} STB @b{is} - use Ada; - use GNAT; - use GNAT.Traceback; + @b{use} Ada; + @b{use} GNAT; + @b{use} GNAT.Traceback; - procedure P1 is + @b{procedure} P1 @b{is} TB : Tracebacks_Array (1 .. 10); - -- We are asking for a maximum of 10 stack frames. + --@i{ We are asking for a maximum of 10 stack frames.} Len : Natural; - -- Len will receive the actual number of stack frames returned. - begin + --@i{ Len will receive the actual number of stack frames returned.} + @b{begin} Call_Chain (TB, Len); Text_IO.Put ("In STB.P1 : "); - for K in 1 .. Len loop + @b{for} K @b{in} 1 .. Len @b{loop} Text_IO.Put (Debug_Utilities.Image (TB (K))); Text_IO.Put (' '); - end loop; + @b{end} @b{loop}; Text_IO.New_Line; - end P1; + @b{end} P1; - procedure P2 is - begin + @b{procedure} P2 @b{is} + @b{begin} P1; - end P2; + @b{end} P2; -begin +@b{begin} P2; -end STB; +@b{end} STB; @end smallexample @smallexample @@ -22264,1795 +21552,100 @@ only the non-symbolic information will be valid. @subsubsection Tracebacks From Exception Occurrences @smallexample @c ada -with Ada.Text_IO; -with GNAT.Traceback.Symbolic; - -procedure STB is - - procedure P1 is - begin - raise Constraint_Error; - end P1; - - procedure P2 is - begin - P1; - end P2; - - procedure P3 is - begin - P2; - end P3; - -begin - P3; -exception - when E : others => - Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E)); -end STB; -@end smallexample - -@smallexample -$ gnatmake -g .\stb -bargs -E -$ stb - -0040149F in stb.p1 at stb.adb:8 -004014B7 in stb.p2 at stb.adb:13 -004014CF in stb.p3 at stb.adb:18 -004015DD in ada.stb at stb.adb:22 -00401461 in main at b~stb.adb:168 -004011C4 in __mingw_CRTStartup at crt1.c:200 -004011F1 in mainCRTStartup at crt1.c:222 -77E892A4 in ?? at ??:0 -@end smallexample - -@noindent -In the above example the ``.\'' syntax in the @command{gnatmake} command -is currently required by @command{addr2line} for files that are in -the current working directory. -Moreover, the exact sequence of linker options may vary from platform -to platform. -The above @option{-largs} section is for Windows platforms. By contrast, -under Unix there is no need for the @option{-largs} section. -Differences across platforms are due to details of linker implementation. - -@node Tracebacks From Anywhere in a Program (symbolic) -@subsubsection Tracebacks From Anywhere in a Program - -@noindent -It is possible to get a symbolic stack traceback -from anywhere in a program, just as for non-symbolic tracebacks. -The first step is to obtain a non-symbolic -traceback, and then call @code{Symbolic_Traceback} to compute the symbolic -information. Here is an example: - -@smallexample @c ada -with Ada.Text_IO; -with GNAT.Traceback; -with GNAT.Traceback.Symbolic; - -procedure STB is - - use Ada; - use GNAT.Traceback; - use GNAT.Traceback.Symbolic; - - procedure P1 is - TB : Tracebacks_Array (1 .. 10); - -- We are asking for a maximum of 10 stack frames. - Len : Natural; - -- Len will receive the actual number of stack frames returned. - begin - Call_Chain (TB, Len); - Text_IO.Put_Line (Symbolic_Traceback (TB (1 .. Len))); - end P1; - - procedure P2 is - begin - P1; - end P2; - -begin - P2; -end STB; -@end smallexample - -@c ****************************** -@ifset vms -@node Compatibility with HP Ada -@chapter Compatibility with HP Ada -@cindex Compatibility - -@noindent -@cindex DEC Ada -@cindex HP Ada -@cindex Compatibility between GNAT and HP Ada -This chapter compares HP Ada (formerly known as ``DEC Ada'') -for OpenVMS Alpha and GNAT for OpenVMS for Alpha and for I64. -GNAT is highly compatible -with HP Ada, and it should generally be straightforward to port code -from the HP Ada environment to GNAT. However, there are a few language -and implementation differences of which the user must be aware. These -differences are discussed in this chapter. In -addition, the operating environment and command structure for the -compiler are different, and these differences are also discussed. - -For further details on these and other compatibility issues, -see Appendix E of the HP publication -@cite{HP Ada, Technical Overview and Comparison on HP Platforms}. - -Except where otherwise indicated, the description of GNAT for OpenVMS -applies to both the Alpha and I64 platforms. - -For information on porting Ada code from GNAT on Alpha OpenVMS to GNAT on -I64 OpenVMS, see @ref{Transitioning to 64-Bit GNAT for OpenVMS}. - -The discussion in this chapter addresses specifically the implementation -of Ada 83 for HP OpenVMS Alpha Systems. In cases where the implementation -of HP Ada differs between OpenVMS Alpha Systems and OpenVMS VAX Systems, -GNAT always follows the Alpha implementation. - -For GNAT running on other than VMS systems, all the HP Ada 83 pragmas and -attributes are recognized, although only a subset of them can sensibly -be implemented. The description of pragmas in -@xref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual}, -indicates whether or not they are applicable to non-VMS systems. - -@menu -* Ada Language Compatibility:: -* Differences in the Definition of Package System:: -* Language-Related Features:: -* The Package STANDARD:: -* The Package SYSTEM:: -* Tasking and Task-Related Features:: -* Pragmas and Pragma-Related Features:: -* Library of Predefined Units:: -* Bindings:: -* Main Program Definition:: -* Implementation-Defined Attributes:: -* Compiler and Run-Time Interfacing:: -* Program Compilation and Library Management:: -* Input-Output:: -* Implementation Limits:: -* Tools and Utilities:: -@end menu - -@node Ada Language Compatibility -@section Ada Language Compatibility - -@noindent -GNAT handles Ada 95 and Ada 2005 as well as Ada 83, whereas HP Ada is only -for Ada 83. Ada 95 and Ada 2005 are almost completely upwards compatible -with Ada 83, and therefore Ada 83 programs will compile -and run under GNAT with -no changes or only minor changes. The @cite{Annotated Ada Reference Manual} -provides details on specific incompatibilities. - -GNAT provides the switch @option{/83} on the @command{GNAT COMPILE} command, -as well as the pragma @code{ADA_83}, to force the compiler to -operate in Ada 83 mode. This mode does not guarantee complete -conformance to Ada 83, but in practice is sufficient to -eliminate most sources of incompatibilities. -In particular, it eliminates the recognition of the -additional Ada 95 and Ada 2005 keywords, so that their use as identifiers -in Ada 83 programs is legal, and handles the cases of packages -with optional bodies, and generics that instantiate unconstrained -types without the use of @code{(<>)}. - -@node Differences in the Definition of Package System -@section Differences in the Definition of Package @code{System} - -@noindent -An Ada compiler is allowed to add -implementation-dependent declarations to package @code{System}. -In normal mode, -GNAT does not take advantage of this permission, and the version of -@code{System} provided by GNAT exactly matches that defined in the Ada -Reference Manual. - -However, HP Ada adds an extensive set of declarations to package -@code{System}, -as fully documented in the HP Ada manuals. To minimize changes required -for programs that make use of these extensions, GNAT provides the pragma -@code{Extend_System} for extending the definition of package System. By using: -@cindex pragma @code{Extend_System} -@cindex @code{Extend_System} pragma - -@smallexample @c ada -@group -@cartouche -pragma Extend_System (Aux_DEC); -@end cartouche -@end group -@end smallexample - -@noindent -the set of definitions in @code{System} is extended to include those in -package @code{System.Aux_DEC}. -@cindex @code{System.Aux_DEC} package -@cindex @code{Aux_DEC} package (child of @code{System}) -These definitions are incorporated directly into package @code{System}, -as though they had been declared there. For a -list of the declarations added, see the spec of this package, -which can be found in the file @file{s-auxdec.ads} in the GNAT library. -@cindex @file{s-auxdec.ads} file -The pragma @code{Extend_System} is a configuration pragma, which means that -it can be placed in the file @file{gnat.adc}, so that it will automatically -apply to all subsequent compilations. See @ref{Configuration Pragmas}, -for further details. - -An alternative approach that avoids the use of the non-standard -@code{Extend_System} pragma is to add a context clause to the unit that -references these facilities: - -@smallexample @c ada -@cartouche -with System.Aux_DEC; -use System.Aux_DEC; -@end cartouche -@end smallexample - -@noindent -The effect is not quite semantically identical to incorporating -the declarations directly into package @code{System}, -but most programs will not notice a difference -unless they use prefix notation (e.g.@: @code{System.Integer_8}) -to reference the entities directly in package @code{System}. -For units containing such references, -the prefixes must either be removed, or the pragma @code{Extend_System} -must be used. - -@node Language-Related Features -@section Language-Related Features - -@noindent -The following sections highlight differences in types, -representations of types, operations, alignment, and -related topics. - -@menu -* Integer Types and Representations:: -* Floating-Point Types and Representations:: -* Pragmas Float_Representation and Long_Float:: -* Fixed-Point Types and Representations:: -* Record and Array Component Alignment:: -* Address Clauses:: -* Other Representation Clauses:: -@end menu - -@node Integer Types and Representations -@subsection Integer Types and Representations - -@noindent -The set of predefined integer types is identical in HP Ada and GNAT. -Furthermore the representation of these integer types is also identical, -including the capability of size clauses forcing biased representation. - -In addition, -HP Ada for OpenVMS Alpha systems has defined the -following additional integer types in package @code{System}: - -@itemize @bullet - -@item -@code{INTEGER_8} - -@item -@code{INTEGER_16} - -@item -@code{INTEGER_32} - -@item -@code{INTEGER_64} - -@item -@code{LARGEST_INTEGER} -@end itemize - -@noindent -In GNAT, the first four of these types may be obtained from the -standard Ada package @code{Interfaces}. -Alternatively, by use of the pragma @code{Extend_System}, identical -declarations can be referenced directly in package @code{System}. -On both GNAT and HP Ada, the maximum integer size is 64 bits. - -@node Floating-Point Types and Representations -@subsection Floating-Point Types and Representations -@cindex Floating-Point types - -@noindent -The set of predefined floating-point types is identical in HP Ada and GNAT. -Furthermore the representation of these floating-point -types is also identical. One important difference is that the default -representation for HP Ada is @code{VAX_Float}, but the default representation -for GNAT is IEEE. - -Specific types may be declared to be @code{VAX_Float} or IEEE, using the -pragma @code{Float_Representation} as described in the HP Ada -documentation. -For example, the declarations: - -@smallexample @c ada -@cartouche -type F_Float is digits 6; -pragma Float_Representation (VAX_Float, F_Float); -@end cartouche -@end smallexample - -@noindent -declares a type @code{F_Float} that will be represented in @code{VAX_Float} -format. -This set of declarations actually appears in @code{System.Aux_DEC}, -which contains -the full set of additional floating-point declarations provided in -the HP Ada version of package @code{System}. -This and similar declarations may be accessed in a user program -by using pragma @code{Extend_System}. The use of this -pragma, and the related pragma @code{Long_Float} is described in further -detail in the following section. - -@node Pragmas Float_Representation and Long_Float -@subsection Pragmas @code{Float_Representation} and @code{Long_Float} - -@noindent -HP Ada provides the pragma @code{Float_Representation}, which -acts as a program library switch to allow control over -the internal representation chosen for the predefined -floating-point types declared in the package @code{Standard}. -The format of this pragma is as follows: - -@smallexample @c ada -@cartouche -pragma Float_Representation(VAX_Float | IEEE_Float); -@end cartouche -@end smallexample - -@noindent -This pragma controls the representation of floating-point -types as follows: - -@itemize @bullet -@item -@code{VAX_Float} specifies that floating-point -types are represented by default with the VAX system hardware types -@code{F-floating}, @code{D-floating}, @code{G-floating}. -Note that the @code{H-floating} -type was available only on VAX systems, and is not available -in either HP Ada or GNAT. - -@item -@code{IEEE_Float} specifies that floating-point -types are represented by default with the IEEE single and -double floating-point types. -@end itemize - -@noindent -GNAT provides an identical implementation of the pragma -@code{Float_Representation}, except that it functions as a -configuration pragma. Note that the -notion of configuration pragma corresponds closely to the -HP Ada notion of a program library switch. - -When no pragma is used in GNAT, the default is @code{IEEE_Float}, -which is different -from HP Ada 83, where the default is @code{VAX_Float}. In addition, the -predefined libraries in GNAT are built using @code{IEEE_Float}, so it is not -advisable to change the format of numbers passed to standard library -routines, and if necessary explicit type conversions may be needed. - -The use of @code{IEEE_Float} is recommended in GNAT since it is more -efficient, and (given that it conforms to an international standard) -potentially more portable. -The situation in which @code{VAX_Float} may be useful is in interfacing -to existing code and data that expect the use of @code{VAX_Float}. -In such a situation use the predefined @code{VAX_Float} -types in package @code{System}, as extended by -@code{Extend_System}. For example, use @code{System.F_Float} -to specify the 32-bit @code{F-Float} format. - -@noindent -On OpenVMS systems, HP Ada provides the pragma @code{Long_Float} -to allow control over the internal representation chosen -for the predefined type @code{Long_Float} and for floating-point -type declarations with digits specified in the range 7 .. 15. -The format of this pragma is as follows: - -@smallexample @c ada -@cartouche -pragma Long_Float (D_FLOAT | G_FLOAT); -@end cartouche -@end smallexample - -@node Fixed-Point Types and Representations -@subsection Fixed-Point Types and Representations - -@noindent -On HP Ada for OpenVMS Alpha systems, rounding is -away from zero for both positive and negative numbers. -Therefore, @code{+0.5} rounds to @code{1}, -and @code{-0.5} rounds to @code{-1}. - -On GNAT the results of operations -on fixed-point types are in accordance with the Ada -rules. In particular, results of operations on decimal -fixed-point types are truncated. - -@node Record and Array Component Alignment -@subsection Record and Array Component Alignment - -@noindent -On HP Ada for OpenVMS Alpha, all non-composite components -are aligned on natural boundaries. For example, 1-byte -components are aligned on byte boundaries, 2-byte -components on 2-byte boundaries, 4-byte components on 4-byte -byte boundaries, and so on. The OpenVMS Alpha hardware -runs more efficiently with naturally aligned data. - -On GNAT, alignment rules are compatible -with HP Ada for OpenVMS Alpha. - -@node Address Clauses -@subsection Address Clauses - -@noindent -In HP Ada and GNAT, address clauses are supported for -objects and imported subprograms. -The predefined type @code{System.Address} is a private type -in both compilers on Alpha OpenVMS, with the same representation -(it is simply a machine pointer). Addition, subtraction, and comparison -operations are available in the standard Ada package -@code{System.Storage_Elements}, or in package @code{System} -if it is extended to include @code{System.Aux_DEC} using a -pragma @code{Extend_System} as previously described. - -Note that code that @code{with}'s both this extended package @code{System} -and the package @code{System.Storage_Elements} should not @code{use} -both packages, or ambiguities will result. In general it is better -not to mix these two sets of facilities. The Ada package was -designed specifically to provide the kind of features that HP Ada -adds directly to package @code{System}. - -The type @code{System.Address} is a 64-bit integer type in GNAT for -I64 OpenVMS. For more information, -see @ref{Transitioning to 64-Bit GNAT for OpenVMS}. - -GNAT is compatible with HP Ada in its handling of address -clauses, except for some limitations in -the form of address clauses for composite objects with -initialization. Such address clauses are easily replaced -by the use of an explicitly-defined constant as described -in the Ada Reference Manual (13.1(22)). For example, the sequence -of declarations: - -@smallexample @c ada -@cartouche -X, Y : Integer := Init_Func; -Q : String (X .. Y) := "abc"; -@dots{} -for Q'Address use Compute_Address; -@end cartouche -@end smallexample +@b{with} Ada.Text_IO; +@b{with} GNAT.Traceback.Symbolic; -@noindent -will be rejected by GNAT, since the address cannot be computed at the time -that @code{Q} is declared. To achieve the intended effect, write instead: - -@smallexample @c ada -@group -@cartouche -X, Y : Integer := Init_Func; -Q_Address : constant Address := Compute_Address; -Q : String (X .. Y) := "abc"; -@dots{} -for Q'Address use Q_Address; -@end cartouche -@end group -@end smallexample - -@noindent -which will be accepted by GNAT (and other Ada compilers), and is also -compatible with Ada 83. A fuller description of the restrictions -on address specifications is found in @ref{Top, GNAT Reference Manual, -About This Guide, gnat_rm, GNAT Reference Manual}. - -@node Other Representation Clauses -@subsection Other Representation Clauses - -@noindent -GNAT implements in a compatible manner all the representation -clauses supported by HP Ada. In addition, GNAT -implements the representation clause forms that were introduced in Ada 95, -including @code{COMPONENT_SIZE} and @code{SIZE} clauses for objects. - -@node The Package STANDARD -@section The Package @code{STANDARD} - -@noindent -The package @code{STANDARD}, as implemented by HP Ada, is fully -described in the @cite{Ada Reference Manual} and in the -@cite{HP Ada Language Reference Manual}. As implemented by GNAT, the -package @code{STANDARD} is described in the @cite{Ada Reference Manual}. - -In addition, HP Ada supports the Latin-1 character set in -the type @code{CHARACTER}. GNAT supports the Latin-1 character set -in the type @code{CHARACTER} and also Unicode (ISO 10646 BMP) in -the type @code{WIDE_CHARACTER}. - -The floating-point types supported by GNAT are those -supported by HP Ada, but the defaults are different, and are controlled by -pragmas. See @ref{Floating-Point Types and Representations}, for details. - -@node The Package SYSTEM -@section The Package @code{SYSTEM} - -@noindent -HP Ada provides a specific version of the package -@code{SYSTEM} for each platform on which the language is implemented. -For the complete spec of the package @code{SYSTEM}, see -Appendix F of the @cite{HP Ada Language Reference Manual}. - -On HP Ada, the package @code{SYSTEM} includes the following conversion -functions: -@itemize @bullet -@item @code{TO_ADDRESS(INTEGER)} - -@item @code{TO_ADDRESS(UNSIGNED_LONGWORD)} - -@item @code{TO_ADDRESS(}@i{universal_integer}@code{)} - -@item @code{TO_INTEGER(ADDRESS)} - -@item @code{TO_UNSIGNED_LONGWORD(ADDRESS)} - -@item Function @code{IMPORT_VALUE return UNSIGNED_LONGWORD} and the -functions @code{IMPORT_ADDRESS} and @code{IMPORT_LARGEST_VALUE} -@end itemize - -@noindent -By default, GNAT supplies a version of @code{SYSTEM} that matches -the definition given in the @cite{Ada Reference Manual}. -This -is a subset of the HP system definitions, which is as -close as possible to the original definitions. The only difference -is that the definition of @code{SYSTEM_NAME} is different: - -@smallexample @c ada -@cartouche -type Name is (SYSTEM_NAME_GNAT); -System_Name : constant Name := SYSTEM_NAME_GNAT; -@end cartouche -@end smallexample - -@noindent -Also, GNAT adds the Ada declarations for -@code{BIT_ORDER} and @code{DEFAULT_BIT_ORDER}. - -However, the use of the following pragma causes GNAT -to extend the definition of package @code{SYSTEM} so that it -encompasses the full set of HP-specific extensions, -including the functions listed above: - -@smallexample @c ada -@cartouche -pragma Extend_System (Aux_DEC); -@end cartouche -@end smallexample - -@noindent -The pragma @code{Extend_System} is a configuration pragma that -is most conveniently placed in the @file{gnat.adc} file. @xref{Pragma -Extend_System,,, gnat_rm, GNAT Reference Manual}, for further details. - -HP Ada does not allow the recompilation of the package -@code{SYSTEM}. Instead HP Ada provides several pragmas -(@code{SYSTEM_NAME}, @code{STORAGE_UNIT}, and @code{MEMORY_SIZE}) -to modify values in the package @code{SYSTEM}. -On OpenVMS Alpha systems, the pragma -@code{SYSTEM_NAME} takes the enumeration literal @code{OPENVMS_AXP} as -its single argument. - -GNAT does permit the recompilation of package @code{SYSTEM} using -the special switch @option{-gnatg}, and this switch can be used if -it is necessary to modify the definitions in @code{SYSTEM}. GNAT does -not permit the specification of @code{SYSTEM_NAME}, @code{STORAGE_UNIT} -or @code{MEMORY_SIZE} by any other means. - -On GNAT systems, the pragma @code{SYSTEM_NAME} takes the -enumeration literal @code{SYSTEM_NAME_GNAT}. - -The definitions provided by the use of - -@smallexample @c ada -pragma Extend_System (AUX_Dec); -@end smallexample - -@noindent -are virtually identical to those provided by the HP Ada 83 package -@code{SYSTEM}. One important difference is that the name of the -@code{TO_ADDRESS} -function for type @code{UNSIGNED_LONGWORD} is changed to -@code{TO_ADDRESS_LONG}. -@xref{Address Clauses,,, gnat_rm, GNAT Reference Manual}, for a -discussion of why this change was necessary. - -@noindent -The version of @code{TO_ADDRESS} taking a @i{universal_integer} argument -is in fact -an extension to Ada 83 not strictly compatible with the reference manual. -GNAT, in order to be exactly compatible with the standard, -does not provide this capability. In HP Ada 83, the -point of this definition is to deal with a call like: - -@smallexample @c ada -TO_ADDRESS (16#12777#); -@end smallexample - -@noindent -Normally, according to Ada 83 semantics, one would expect this to be -ambiguous, since it matches both the @code{INTEGER} and -@code{UNSIGNED_LONGWORD} forms of @code{TO_ADDRESS}. -However, in HP Ada 83, there is no ambiguity, since the -definition using @i{universal_integer} takes precedence. - -In GNAT, since the version with @i{universal_integer} cannot be supplied, -it is -not possible to be 100% compatible. Since there are many programs using -numeric constants for the argument to @code{TO_ADDRESS}, the decision in -GNAT was -to change the name of the function in the @code{UNSIGNED_LONGWORD} case, -so the declarations provided in the GNAT version of @code{AUX_Dec} are: - -@smallexample @c ada -function To_Address (X : Integer) return Address; -pragma Pure_Function (To_Address); - -function To_Address_Long (X : Unsigned_Longword) return Address; -pragma Pure_Function (To_Address_Long); -@end smallexample - -@noindent -This means that programs using @code{TO_ADDRESS} for -@code{UNSIGNED_LONGWORD} must change the name to @code{TO_ADDRESS_LONG}. - -@node Tasking and Task-Related Features -@section Tasking and Task-Related Features - -@noindent -This section compares the treatment of tasking in GNAT -and in HP Ada for OpenVMS Alpha. -The GNAT description applies to both Alpha and I64 OpenVMS. -For detailed information on tasking in -HP Ada, see the @cite{HP Ada Language Reference Manual} and the -relevant run-time reference manual. - -@menu -* Implementation of Tasks in HP Ada for OpenVMS Alpha Systems:: -* Assigning Task IDs:: -* Task IDs and Delays:: -* Task-Related Pragmas:: -* Scheduling and Task Priority:: -* The Task Stack:: -* External Interrupts:: -@end menu - -@node Implementation of Tasks in HP Ada for OpenVMS Alpha Systems -@subsection Implementation of Tasks in HP Ada for OpenVMS Alpha Systems - -@noindent -On OpenVMS Alpha systems, each Ada task (except a passive -task) is implemented as a single stream of execution -that is created and managed by the kernel. On these -systems, HP Ada tasking support is based on DECthreads, -an implementation of the POSIX standard for threads. - -Also, on OpenVMS Alpha systems, HP Ada tasks and foreign -code that calls DECthreads routines can be used together. -The interaction between Ada tasks and DECthreads routines -can have some benefits. For example when on OpenVMS Alpha, -HP Ada can call C code that is already threaded. - -GNAT uses the facilities of DECthreads, -and Ada tasks are mapped to threads. - -@node Assigning Task IDs -@subsection Assigning Task IDs - -@noindent -The HP Ada Run-Time Library always assigns @code{%TASK 1} to -the environment task that executes the main program. On -OpenVMS Alpha systems, @code{%TASK 0} is often used for tasks -that have been created but are not yet activated. - -On OpenVMS Alpha systems, task IDs are assigned at -activation. On GNAT systems, task IDs are also assigned at -task creation but do not have the same form or values as -task ID values in HP Ada. There is no null task, and the -environment task does not have a specific task ID value. - -@node Task IDs and Delays -@subsection Task IDs and Delays - -@noindent -On OpenVMS Alpha systems, tasking delays are implemented -using Timer System Services. The Task ID is used for the -identification of the timer request (the @code{REQIDT} parameter). -If Timers are used in the application take care not to use -@code{0} for the identification, because cancelling such a timer -will cancel all timers and may lead to unpredictable results. - -@node Task-Related Pragmas -@subsection Task-Related Pragmas - -@noindent -Ada supplies the pragma @code{TASK_STORAGE}, which allows -specification of the size of the guard area for a task -stack. (The guard area forms an area of memory that has no -read or write access and thus helps in the detection of -stack overflow.) On OpenVMS Alpha systems, if the pragma -@code{TASK_STORAGE} specifies a value of zero, a minimal guard -area is created. In the absence of a pragma @code{TASK_STORAGE}, -a default guard area is created. - -GNAT supplies the following task-related pragma: - -@itemize -@item @code{TASK_STORAGE} - -GNAT implements pragma @code{TASK_STORAGE} in the same way as HP Ada. -Both HP Ada and GNAT supply the pragmas @code{PASSIVE}, -@code{SUPPRESS}, and @code{VOLATILE}. -@end itemize - -@node Scheduling and Task Priority -@subsection Scheduling and Task Priority - -@noindent -HP Ada implements the Ada language requirement that -when two tasks are eligible for execution and they have -different priorities, the lower priority task does not -execute while the higher priority task is waiting. The HP -Ada Run-Time Library keeps a task running until either the -task is suspended or a higher priority task becomes ready. - -On OpenVMS Alpha systems, the default strategy is round- -robin with preemption. Tasks of equal priority take turns -at the processor. A task is run for a certain period of -time and then placed at the tail of the ready queue for -its priority level. - -HP Ada provides the implementation-defined pragma @code{TIME_SLICE}, -which can be used to enable or disable round-robin -scheduling of tasks with the same priority. -See the relevant HP Ada run-time reference manual for -information on using the pragmas to control HP Ada task -scheduling. - -GNAT follows the scheduling rules of Annex D (Real-Time -Annex) of the @cite{Ada Reference Manual}. In general, this -scheduling strategy is fully compatible with HP Ada -although it provides some additional constraints (as -fully documented in Annex D). -GNAT implements time slicing control in a manner compatible with -HP Ada 83, by means of the pragma @code{Time_Slice}, whose semantics -are identical to the HP Ada 83 pragma of the same name. -Note that it is not possible to mix GNAT tasking and -HP Ada 83 tasking in the same program, since the two run-time -libraries are not compatible. - -@node The Task Stack -@subsection The Task Stack - -@noindent -In HP Ada, a task stack is allocated each time a -non-passive task is activated. As soon as the task is -terminated, the storage for the task stack is deallocated. -If you specify a size of zero (bytes) with @code{T'STORAGE_SIZE}, -a default stack size is used. Also, regardless of the size -specified, some additional space is allocated for task -management purposes. On OpenVMS Alpha systems, at least -one page is allocated. - -GNAT handles task stacks in a similar manner. In accordance with -the Ada rules, it provides the pragma @code{STORAGE_SIZE} as -an alternative method for controlling the task stack size. -The specification of the attribute @code{T'STORAGE_SIZE} is also -supported in a manner compatible with HP Ada. - -@node External Interrupts -@subsection External Interrupts - -@noindent -On HP Ada, external interrupts can be associated with task entries. -GNAT is compatible with HP Ada in its handling of external interrupts. - -@node Pragmas and Pragma-Related Features -@section Pragmas and Pragma-Related Features - -@noindent -Both HP Ada and GNAT supply all language-defined pragmas -as specified by the Ada 83 standard. GNAT also supplies all -language-defined pragmas introduced by Ada 95 and Ada 2005. -In addition, GNAT implements the implementation-defined pragmas -from HP Ada 83. - -@itemize @bullet -@item @code{AST_ENTRY} - -@item @code{COMMON_OBJECT} - -@item @code{COMPONENT_ALIGNMENT} - -@item @code{EXPORT_EXCEPTION} - -@item @code{EXPORT_FUNCTION} - -@item @code{EXPORT_OBJECT} - -@item @code{EXPORT_PROCEDURE} - -@item @code{EXPORT_VALUED_PROCEDURE} - -@item @code{FLOAT_REPRESENTATION} - -@item @code{IDENT} - -@item @code{IMPORT_EXCEPTION} - -@item @code{IMPORT_FUNCTION} - -@item @code{IMPORT_OBJECT} - -@item @code{IMPORT_PROCEDURE} - -@item @code{IMPORT_VALUED_PROCEDURE} - -@item @code{INLINE_GENERIC} - -@item @code{INTERFACE_NAME} - -@item @code{LONG_FLOAT} - -@item @code{MAIN_STORAGE} - -@item @code{PASSIVE} - -@item @code{PSECT_OBJECT} - -@item @code{SHARE_GENERIC} - -@item @code{SUPPRESS_ALL} - -@item @code{TASK_STORAGE} - -@item @code{TIME_SLICE} - -@item @code{TITLE} -@end itemize - -@noindent -These pragmas are all fully implemented, with the exception of @code{TITLE}, -@code{PASSIVE}, and @code{SHARE_GENERIC}, which are -recognized, but which have no -effect in GNAT. The effect of @code{PASSIVE} may be obtained by the -use of Ada protected objects. In GNAT, all generics are inlined. - -Unlike HP Ada, the GNAT ``@code{EXPORT_}@i{subprogram}'' pragmas require -a separate subprogram specification which must appear before the -subprogram body. - -GNAT also supplies a number of implementation-defined pragmas including the -following: - -@itemize @bullet -@item @code{ABORT_DEFER} - -@item @code{ADA_83} - -@item @code{ADA_95} - -@item @code{ADA_05} - -@item @code{Ada_2005} - -@item @code{Ada_12} - -@item @code{Ada_2012} - -@item @code{ALLOW_INTEGER_ADDRESS} - -@item @code{ANNOTATE} - -@item @code{ASSERT} - -@item @code{C_PASS_BY_COPY} - -@item @code{CPP_CLASS} - -@item @code{CPP_CONSTRUCTOR} - -@item @code{CPP_DESTRUCTOR} - -@item @code{DEBUG} - -@item @code{EXTEND_SYSTEM} - -@item @code{LINKER_ALIAS} - -@item @code{LINKER_SECTION} - -@item @code{MACHINE_ATTRIBUTE} - -@item @code{NO_RETURN} - -@item @code{PURE_FUNCTION} - -@item @code{SOURCE_FILE_NAME} - -@item @code{SOURCE_REFERENCE} - -@item @code{UNCHECKED_UNION} - -@item @code{UNIMPLEMENTED_UNIT} - -@item @code{UNIVERSAL_DATA} - -@item @code{UNSUPPRESS} - -@item @code{WARNINGS} - -@item @code{WEAK_EXTERNAL} -@end itemize - -@noindent -For full details on these and other GNAT implementation-defined pragmas, -see @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference -Manual}. - -@menu -* Restrictions on the Pragma INLINE:: -* Restrictions on the Pragma INTERFACE:: -* Restrictions on the Pragma SYSTEM_NAME:: -@end menu - -@node Restrictions on the Pragma INLINE -@subsection Restrictions on Pragma @code{INLINE} - -@noindent -HP Ada enforces the following restrictions on the pragma @code{INLINE}: -@itemize @bullet -@item Parameters cannot have a task type. - -@item Function results cannot be task types, unconstrained -array types, or unconstrained types with discriminants. - -@item Bodies cannot declare the following: -@itemize @bullet -@item Subprogram body or stub (imported subprogram is allowed) - -@item Tasks - -@item Generic declarations - -@item Instantiations - -@item Exceptions - -@item Access types (types derived from access types allowed) - -@item Array or record types - -@item Dependent tasks - -@item Direct recursive calls of subprogram or containing -subprogram, directly or via a renaming - -@end itemize -@end itemize - -@noindent -In GNAT, the only restriction on pragma @code{INLINE} is that the -body must occur before the call if both are in the same -unit, and the size must be appropriately small. There are -no other specific restrictions which cause subprograms to -be incapable of being inlined. - -@node Restrictions on the Pragma INTERFACE -@subsection Restrictions on Pragma @code{INTERFACE} - -@noindent -The following restrictions on pragma @code{INTERFACE} -are enforced by both HP Ada and GNAT: -@itemize @bullet -@item Languages accepted: Ada, Bliss, C, Fortran, Default. -Default is the default on OpenVMS Alpha systems. - -@item Parameter passing: Language specifies default -mechanisms but can be overridden with an @code{EXPORT} pragma. - -@itemize @bullet -@item Ada: Use internal Ada rules. - -@item Bliss, C: Parameters must be mode @code{in}; cannot be -record or task type. Result cannot be a string, an -array, or a record. - -@item Fortran: Parameters cannot have a task type. Result cannot -be a string, an array, or a record. -@end itemize -@end itemize - -@noindent -GNAT is entirely upwards compatible with HP Ada, and in addition allows -record parameters for all languages. - -@node Restrictions on the Pragma SYSTEM_NAME -@subsection Restrictions on Pragma @code{SYSTEM_NAME} - -@noindent -For HP Ada for OpenVMS Alpha, the enumeration literal -for the type @code{NAME} is @code{OPENVMS_AXP}. -In GNAT, the enumeration -literal for the type @code{NAME} is @code{SYSTEM_NAME_GNAT}. - -@node Library of Predefined Units -@section Library of Predefined Units - -@noindent -A library of predefined units is provided as part of the -HP Ada and GNAT implementations. HP Ada does not provide -the package @code{MACHINE_CODE} but instead recommends importing -assembler code. - -The GNAT versions of the HP Ada Run-Time Library (@code{ADA$PREDEFINED:}) -units are taken from the OpenVMS Alpha version, not the OpenVMS VAX -version. -The HP Ada Predefined Library units are modified to remove post-Ada 83 -incompatibilities and to make them interoperable with GNAT -(@pxref{Changes to DECLIB}, for details). -The units are located in the @file{DECLIB} directory. - -The GNAT RTL is contained in -the @file{ADALIB} directory, and -the default search path is set up to find @code{DECLIB} units in preference -to @code{ADALIB} units with the same name (@code{TEXT_IO}, -@code{SEQUENTIAL_IO}, and @code{DIRECT_IO}, for example). - -@menu -* Changes to DECLIB:: -@end menu - -@node Changes to DECLIB -@subsection Changes to @code{DECLIB} - -@noindent -The changes made to the HP Ada predefined library for GNAT and post-Ada 83 -compatibility are minor and include the following: - -@itemize @bullet -@item Adjusting the location of pragmas and record representation -clauses to obey Ada 95 (and thus Ada 2005) rules - -@item Adding the proper notation to generic formal parameters -that take unconstrained types in instantiation - -@item Adding pragma @code{ELABORATE_BODY} to package specs -that have package bodies not otherwise allowed - -@item Replacing occurrences of the identifier ``@code{PROTECTED}'' by -``@code{PROTECTD}''. -Currently these are found only in the @code{STARLET} package spec. - -@item Changing @code{SYSTEM.ADDRESS} to @code{SYSTEM.SHORT_ADDRESS} -where the address size is constrained to 32 bits. -@end itemize - -@noindent -None of the above changes is visible to users. - -@node Bindings -@section Bindings - -@noindent -On OpenVMS Alpha, HP Ada provides the following strongly-typed bindings: -@itemize @bullet - -@item Command Language Interpreter (CLI interface) - -@item DECtalk Run-Time Library (DTK interface) - -@item Librarian utility routines (LBR interface) - -@item General Purpose Run-Time Library (LIB interface) - -@item Math Run-Time Library (MTH interface) - -@item National Character Set Run-Time Library (NCS interface) - -@item Compiled Code Support Run-Time Library (OTS interface) - -@item Parallel Processing Run-Time Library (PPL interface) - -@item Screen Management Run-Time Library (SMG interface) - -@item Sort Run-Time Library (SOR interface) - -@item String Run-Time Library (STR interface) - -@item STARLET System Library -@findex Starlet - -@item X Window System Version 11R4 and 11R5 (X, XLIB interface) - -@item X Windows Toolkit (XT interface) - -@item X/Motif Version 1.1.3 and 1.2 (XM interface) -@end itemize - -@noindent -GNAT provides implementations of these HP bindings in the @code{DECLIB} -directory, on both the Alpha and I64 OpenVMS platforms. - -The X components of DECLIB compatibility package are located in a separate -library, called XDECGNAT, which is not linked with by default; this library -must be explicitly linked with any application that makes use of any X facilities, -with a command similar to - -@code{GNAT MAKE USE_X /LINK /LIBRARY=XDECGNAT} - -The X/Motif bindings used to build @code{DECLIB} are whatever versions are -in the -HP Ada @file{ADA$PREDEFINED} directory with extension @file{.ADC}. -A pragma @code{Linker_Options} has been added to packages @code{Xm}, -@code{Xt}, and @code{X_Lib} -causing the default X/Motif sharable image libraries to be linked in. This -is done via options files named @file{xm.opt}, @file{xt.opt}, and -@file{x_lib.opt} (also located in the @file{DECLIB} directory). - -It may be necessary to edit these options files to update or correct the -library names if, for example, the newer X/Motif bindings from -@file{ADA$EXAMPLES} -had been (previous to installing GNAT) copied and renamed to supersede the -default @file{ADA$PREDEFINED} versions. - -@menu -* Shared Libraries and Options Files:: -* Interfaces to C:: -@end menu - -@node Shared Libraries and Options Files -@subsection Shared Libraries and Options Files - -@noindent -When using the HP Ada -predefined X and Motif bindings, the linking with their sharable images is -done automatically by @command{GNAT LINK}. -When using other X and Motif bindings, you need -to add the corresponding sharable images to the command line for -@code{GNAT LINK}. When linking with shared libraries, or with -@file{.OPT} files, you must -also add them to the command line for @command{GNAT LINK}. - -A shared library to be used with GNAT is built in the same way as other -libraries under VMS. The VMS Link command can be used in standard fashion. - -@node Interfaces to C -@subsection Interfaces to C - -@noindent -HP Ada -provides the following Ada types and operations: - -@itemize @bullet -@item C types package (@code{C_TYPES}) - -@item C strings (@code{C_TYPES.NULL_TERMINATED}) - -@item Other_types (@code{SHORT_INT}) -@end itemize - -@noindent -Interfacing to C with GNAT, you can use the above approach -described for HP Ada or the facilities of Annex B of -the @cite{Ada Reference Manual} (packages @code{INTERFACES.C}, -@code{INTERFACES.C.STRINGS} and @code{INTERFACES.C.POINTERS}). For more -information, see @ref{Interfacing to C,,, gnat_rm, GNAT Reference Manual}. - -The @option{-gnatF} qualifier forces default and explicit -@code{External_Name} parameters in pragmas @code{Import} and @code{Export} -to be uppercased for compatibility with the default behavior -of HP C. The qualifier has no effect on @code{Link_Name} parameters. - -@node Main Program Definition -@section Main Program Definition - -@noindent -The following section discusses differences in the -definition of main programs on HP Ada and GNAT. -On HP Ada, main programs are defined to meet the -following conditions: -@itemize @bullet -@item Procedure with no formal parameters (returns @code{0} upon -normal completion) - -@item Procedure with no formal parameters (returns @code{42} when -an unhandled exception is raised) - -@item Function with no formal parameters whose returned value -is of a discrete type - -@item Procedure with one @code{out} formal of a discrete type for -which a specification of pragma @code{EXPORT_VALUED_PROCEDURE} is given. - -@end itemize - -@noindent -When declared with the pragma @code{EXPORT_VALUED_PROCEDURE}, -a main function or main procedure returns a discrete -value whose size is less than 64 bits (32 on VAX systems), -the value is zero- or sign-extended as appropriate. -On GNAT, main programs are defined as follows: -@itemize @bullet -@item Must be a non-generic, parameterless subprogram that -is either a procedure or function returning an Ada -@code{STANDARD.INTEGER} (the predefined type) - -@item Cannot be a generic subprogram or an instantiation of a -generic subprogram -@end itemize - -@node Implementation-Defined Attributes -@section Implementation-Defined Attributes - -@noindent -GNAT provides all HP Ada implementation-defined -attributes. - -@node Compiler and Run-Time Interfacing -@section Compiler and Run-Time Interfacing - -@noindent -HP Ada provides the following qualifiers to pass options to the linker -(ACS LINK): -@itemize @bullet -@item @option{/WAIT} and @option{/SUBMIT} - -@item @option{/COMMAND} - -@item @option{/@r{[}NO@r{]}MAP} - -@item @option{/OUTPUT=@var{file-spec}} - -@item @option{/@r{[}NO@r{]}DEBUG} and @option{/@r{[}NO@r{]}TRACEBACK} -@end itemize - -@noindent -To pass options to the linker, GNAT provides the following -switches: - -@itemize @bullet -@item @option{/EXECUTABLE=@var{exec-name}} - -@item @option{/VERBOSE} - -@item @option{/@r{[}NO@r{]}DEBUG} and @option{/@r{[}NO@r{]}TRACEBACK} -@end itemize - -@noindent -For more information on these switches, see -@ref{Switches for gnatlink}. -In HP Ada, the command-line switch @option{/OPTIMIZE} is available -to control optimization. HP Ada also supplies the -following pragmas: -@itemize @bullet -@item @code{OPTIMIZE} - -@item @code{INLINE} - -@item @code{INLINE_GENERIC} - -@item @code{SUPPRESS_ALL} - -@item @code{PASSIVE} -@end itemize - -@noindent -In GNAT, optimization is controlled strictly by command -line parameters, as described in the corresponding section of this guide. -The HP pragmas for control of optimization are -recognized but ignored. - -Note that in GNAT, the default is optimization off, whereas in HP Ada -the default is that optimization is turned on. - -@node Program Compilation and Library Management -@section Program Compilation and Library Management - -@noindent -HP Ada and GNAT provide a comparable set of commands to -build programs. HP Ada also provides a program library, -which is a concept that does not exist on GNAT. Instead, -GNAT provides directories of sources that are compiled as -needed. - -The following table summarizes -the HP Ada commands and provides -equivalent GNAT commands. In this table, some GNAT -equivalents reflect the fact that GNAT does not use the -concept of a program library. Instead, it uses a model -in which collections of source and object files are used -in a manner consistent with other languages like C and -Fortran. Therefore, standard system file commands are used -to manipulate these elements. Those GNAT commands are marked with -an asterisk. -Note that, unlike HP Ada, none of the GNAT commands accepts wild cards. - -@need 1500 -@multitable @columnfractions .35 .65 - -@item @emph{HP Ada Command} -@tab @emph{GNAT Equivalent / Description} - -@item @command{ADA} -@tab @command{GNAT COMPILE}@* -Invokes the compiler to compile one or more Ada source files. - -@item @command{ACS ATTACH}@* -@tab [No equivalent]@* -Switches control of terminal from current process running the program -library manager. - -@item @command{ACS CHECK} -@tab @command{GNAT MAKE /DEPENDENCY_LIST}@* -Forms the execution closure of one -or more compiled units and checks completeness and currency. - -@item @command{ACS COMPILE} -@tab @command{GNAT MAKE /ACTIONS=COMPILE}@* -Forms the execution closure of one or -more specified units, checks completeness and currency, -identifies units that have revised source files, compiles same, -and recompiles units that are or will become obsolete. -Also completes incomplete generic instantiations. - -@item @command{ACS COPY FOREIGN} -@tab Copy (*)@* -Copies a foreign object file into the program library as a -library unit body. - -@item @command{ACS COPY UNIT} -@tab Copy (*)@* -Copies a compiled unit from one program library to another. - -@item @command{ACS CREATE LIBRARY} -@tab Create /directory (*)@* -Creates a program library. - -@item @command{ACS CREATE SUBLIBRARY} -@tab Create /directory (*)@* -Creates a program sublibrary. - -@item @command{ACS DELETE LIBRARY} -@tab @* -Deletes a program library and its contents. - -@item @command{ACS DELETE SUBLIBRARY} -@tab @* -Deletes a program sublibrary and its contents. - -@item @command{ACS DELETE UNIT} -@tab Delete file (*)@* -On OpenVMS systems, deletes one or more compiled units from -the current program library. - -@item @command{ACS DIRECTORY} -@tab Directory (*)@* -On OpenVMS systems, lists units contained in the current -program library. - -@item @command{ACS ENTER FOREIGN} -@tab Copy (*)@* -Allows the import of a foreign body as an Ada library -spec and enters a reference to a pointer. - -@item @command{ACS ENTER UNIT} -@tab Copy (*)@* -Enters a reference (pointer) from the current program library to -a unit compiled into another program library. - -@item @command{ACS EXIT} -@tab [No equivalent]@* -Exits from the program library manager. - -@item @command{ACS EXPORT} -@tab Copy (*)@* -Creates an object file that contains system-specific object code -for one or more units. With GNAT, object files can simply be copied -into the desired directory. - -@item @command{ACS EXTRACT SOURCE} -@tab Copy (*)@* -Allows access to the copied source file for each Ada compilation unit - -@item @command{ACS HELP} -@tab @command{HELP GNAT}@* -Provides online help. - -@item @command{ACS LINK} -@tab @command{GNAT LINK}@* -Links an object file containing Ada units into an executable file. - -@item @command{ACS LOAD} -@tab Copy (*)@* -Loads (partially compiles) Ada units into the program library. -Allows loading a program from a collection of files into a library -without knowing the relationship among units. - -@item @command{ACS MERGE} -@tab Copy (*)@* -Merges into the current program library, one or more units from -another library where they were modified. - -@item @command{ACS RECOMPILE} -@tab @command{GNAT MAKE /ACTIONS=COMPILE}@* -Recompiles from external or copied source files any obsolete -unit in the closure. Also, completes any incomplete generic -instantiations. - -@item @command{ACS REENTER} -@tab @command{GNAT MAKE}@* -Reenters current references to units compiled after last entered -with the @command{ACS ENTER UNIT} command. - -@item @command{ACS SET LIBRARY} -@tab Set default (*)@* -Defines a program library to be the compilation context as well -as the target library for compiler output and commands in general. - -@item @command{ACS SET PRAGMA} -@tab Edit @file{gnat.adc} (*)@* -Redefines specified values of the library characteristics -@code{LONG_ FLOAT}, @code{MEMORY_SIZE}, @code{SYSTEM_NAME}, -and @code{Float_Representation}. - -@item @command{ACS SET SOURCE} -@tab Define @code{ADA_INCLUDE_PATH} path (*)@* -Defines the source file search list for the @command{ACS COMPILE} command. - -@item @command{ACS SHOW LIBRARY} -@tab Directory (*)@* -Lists information about one or more program libraries. - -@item @command{ACS SHOW PROGRAM} -@tab [No equivalent]@* -Lists information about the execution closure of one or -more units in the program library. - -@item @command{ACS SHOW SOURCE} -@tab Show logical @code{ADA_INCLUDE_PATH}@* -Shows the source file search used when compiling units. - -@item @command{ACS SHOW VERSION} -@tab Compile with @option{VERBOSE} option -Displays the version number of the compiler and program library -manager used. - -@item @command{ACS SPAWN} -@tab [No equivalent]@* -Creates a subprocess of the current process (same as @command{DCL SPAWN} -command). - -@item @command{ACS VERIFY} -@tab [No equivalent]@* -Performs a series of consistency checks on a program library to -determine whether the library structure and library files are in -valid form. -@end multitable - -@noindent - -@node Input-Output -@section Input-Output - -@noindent -On OpenVMS Alpha systems, HP Ada uses OpenVMS Record -Management Services (RMS) to perform operations on -external files. - -@noindent -HP Ada and GNAT predefine an identical set of input- -output packages. To make the use of the -generic @code{TEXT_IO} operations more convenient, HP Ada -provides predefined library packages that instantiate the -integer and floating-point operations for the predefined -integer and floating-point types as shown in the following table. - -@multitable @columnfractions .45 .55 -@item @emph{Package Name} @tab Instantiation - -@item @code{INTEGER_TEXT_IO} -@tab @code{INTEGER_IO(INTEGER)} - -@item @code{SHORT_INTEGER_TEXT_IO} -@tab @code{INTEGER_IO(SHORT_INTEGER)} - -@item @code{SHORT_SHORT_INTEGER_TEXT_IO} -@tab @code{INTEGER_IO(SHORT_SHORT_INTEGER)} - -@item @code{FLOAT_TEXT_IO} -@tab @code{FLOAT_IO(FLOAT)} - -@item @code{LONG_FLOAT_TEXT_IO} -@tab @code{FLOAT_IO(LONG_FLOAT)} -@end multitable - -@noindent -The HP Ada predefined packages and their operations -are implemented using OpenVMS Alpha files and input-output -facilities. HP Ada supports asynchronous input-output on OpenVMS Alpha. -Familiarity with the following is recommended: -@itemize @bullet -@item RMS file organizations and access methods - -@item OpenVMS file specifications and directories - -@item OpenVMS File Definition Language (FDL) -@end itemize - -@noindent -GNAT provides I/O facilities that are completely -compatible with HP Ada. The distribution includes the -standard HP Ada versions of all I/O packages, operating -in a manner compatible with HP Ada. In particular, the -following packages are by default the HP Ada (Ada 83) -versions of these packages rather than the renamings -suggested in Annex J of the Ada Reference Manual: -@itemize @bullet -@item @code{TEXT_IO} - -@item @code{SEQUENTIAL_IO} - -@item @code{DIRECT_IO} -@end itemize - -@noindent -The use of the standard child package syntax (for -example, @code{ADA.TEXT_IO}) retrieves the post-Ada 83 versions of these -packages. -GNAT provides HP-compatible predefined instantiations -of the @code{TEXT_IO} packages, and also -provides the standard predefined instantiations required -by the @cite{Ada Reference Manual}. - -For further information on how GNAT interfaces to the file -system or how I/O is implemented in programs written in -mixed languages, see @ref{Implementation of the Standard I/O,,, -gnat_rm, GNAT Reference Manual}. -This chapter covers the following: -@itemize @bullet -@item Standard I/O packages +@b{procedure} STB @b{is} -@item @code{FORM} strings + @b{procedure} P1 @b{is} + @b{begin} + @b{raise} Constraint_Error; + @b{end} P1; -@item @code{ADA.DIRECT_IO} + @b{procedure} P2 @b{is} + @b{begin} + P1; + @b{end} P2; -@item @code{ADA.SEQUENTIAL_IO} + @b{procedure} P3 @b{is} + @b{begin} + P2; + @b{end} P3; -@item @code{ADA.TEXT_IO} +@b{begin} + P3; +@b{exception} + @b{when} E : @b{others} => + Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback (E)); +@b{end} STB; +@end smallexample -@item Stream pointer positioning +@smallexample +$ gnatmake -g .\stb -bargs -E +$ stb -@item Reading and writing non-regular files +0040149F in stb.p1 at stb.adb:8 +004014B7 in stb.p2 at stb.adb:13 +004014CF in stb.p3 at stb.adb:18 +004015DD in ada.stb at stb.adb:22 +00401461 in main at b~stb.adb:168 +004011C4 in __mingw_CRTStartup at crt1.c:200 +004011F1 in mainCRTStartup at crt1.c:222 +77E892A4 in ?? at ??:0 +@end smallexample -@item @code{GET_IMMEDIATE} +@noindent +In the above example the ``.\'' syntax in the @command{gnatmake} command +is currently required by @command{addr2line} for files that are in +the current working directory. +Moreover, the exact sequence of linker options may vary from platform +to platform. +The above @option{-largs} section is for Windows platforms. By contrast, +under Unix there is no need for the @option{-largs} section. +Differences across platforms are due to details of linker implementation. -@item Treating @code{TEXT_IO} files as streams +@node Tracebacks From Anywhere in a Program (symbolic) +@subsubsection Tracebacks From Anywhere in a Program -@item Shared files +@noindent +It is possible to get a symbolic stack traceback +from anywhere in a program, just as for non-symbolic tracebacks. +The first step is to obtain a non-symbolic +traceback, and then call @code{Symbolic_Traceback} to compute the symbolic +information. Here is an example: -@item Open modes -@end itemize +@smallexample @c ada +@b{with} Ada.Text_IO; +@b{with} GNAT.Traceback; +@b{with} GNAT.Traceback.Symbolic; -@node Implementation Limits -@section Implementation Limits - -@noindent -The following table lists implementation limits for HP Ada -and GNAT systems. -@multitable @columnfractions .60 .20 .20 -@sp 1 -@item @emph{Compilation Parameter} -@tab @emph{HP Ada} -@tab @emph{GNAT} -@sp 1 - -@item In a subprogram or entry declaration, maximum number of -formal parameters that are of an unconstrained record type -@tab 32 -@tab No set limit -@sp 1 - -@item Maximum identifier length (number of characters) -@tab 255 -@tab 32766 -@sp 1 - -@item Maximum number of characters in a source line -@tab 255 -@tab 32766 -@sp 1 - -@item Maximum collection size (number of bytes) -@tab 2**31-1 -@tab 2**31-1 -@sp 1 - -@item Maximum number of discriminants for a record type -@tab 245 -@tab No set limit -@sp 1 - -@item Maximum number of formal parameters in an entry or -subprogram declaration -@tab 246 -@tab No set limit -@sp 1 - -@item Maximum number of dimensions in an array type -@tab 255 -@tab No set limit -@sp 1 - -@item Maximum number of library units and subunits in a compilation. -@tab 4095 -@tab No set limit -@sp 1 - -@item Maximum number of library units and subunits in an execution. -@tab 16383 -@tab No set limit -@sp 1 - -@item Maximum number of objects declared with the pragma @code{COMMON_OBJECT} -or @code{PSECT_OBJECT} -@tab 32757 -@tab No set limit -@sp 1 - -@item Maximum number of enumeration literals in an enumeration type -definition -@tab 65535 -@tab No set limit -@sp 1 - -@item Maximum number of lines in a source file -@tab 65534 -@tab No set limit -@sp 1 - -@item Maximum number of bits in any object -@tab 2**31-1 -@tab 2**31-1 -@sp 1 - -@item Maximum size of the static portion of a stack frame (approximate) -@tab 2**31-1 -@tab 2**31-1 -@end multitable +@b{procedure} STB @b{is} -@node Tools and Utilities -@section Tools and Utilities + @b{use} Ada; + @b{use} GNAT.Traceback; + @b{use} GNAT.Traceback.Symbolic; -@noindent -The following table lists some of the OpenVMS development tools -available for HP Ada, and the corresponding tools for -use with @value{EDITION} on Alpha and I64 platforms. -Aside from the debugger, all the OpenVMS tools identified are part -of the DECset package. + @b{procedure} P1 @b{is} + TB : Tracebacks_Array (1 .. 10); + --@i{ We are asking for a maximum of 10 stack frames.} + Len : Natural; + --@i{ Len will receive the actual number of stack frames returned.} + @b{begin} + Call_Chain (TB, Len); + Text_IO.Put_Line (Symbolic_Traceback (TB (1 .. Len))); + @b{end} P1; -@iftex -@c Specify table in TeX since Texinfo does a poor job -@tex -\smallskip -\smallskip -\settabs\+Language-Sensitive Editor\quad - &Product with HP Ada\quad - &\cr -\+\it Tool - &\it Product with HP Ada - & \it Product with @value{EDITION}\cr -\smallskip -\+Code Management System - &HP CMS - & HP CMS\cr -\smallskip -\+Language-Sensitive Editor - &HP LSE - & emacs or HP LSE (Alpha)\cr -\+ - & - & HP LSE (I64)\cr -\smallskip -\+Debugger - &OpenVMS Debug - & gdb (Alpha),\cr -\+ - & - & OpenVMS Debug (I64)\cr -\smallskip -\+Source Code Analyzer / - &HP SCA - & GNAT XREF\cr -\+Cross Referencer - & - &\cr -\smallskip -\+Test Manager - &HP Digital Test - & HP DTM\cr -\+ - &Manager (DTM) - &\cr -\smallskip -\+Performance and - & HP PCA - & HP PCA\cr -\+Coverage Analyzer - & - &\cr -\smallskip -\+Module Management - & HP MMS - & Not applicable\cr -\+ System - & - &\cr -\smallskip -\smallskip -@end tex -@end iftex + @b{procedure} P2 @b{is} + @b{begin} + P1; + @b{end} P2; -@ifnottex -@c This is the Texinfo version of the table. It renders poorly in pdf, hence -@c the TeX version above for the printed version -@flushleft -@c @multitable @columnfractions .3 .4 .4 -@multitable {Source Code Analyzer /}{Tool with HP Ada}{Tool with @value{EDITION}} -@item @i{Tool} -@tab @i{Tool with HP Ada} -@tab @i{Tool with @value{EDITION}} -@item Code Management@*System -@tab HP CMS -@tab HP CMS -@item Language-Sensitive@*Editor -@tab HP LSE -@tab emacs or HP LSE (Alpha) -@item -@tab -@tab HP LSE (I64) -@item Debugger -@tab OpenVMS Debug -@tab gdb (Alpha), -@item -@tab -@tab OpenVMS Debug (I64) -@item Source Code Analyzer /@*Cross Referencer -@tab HP SCA -@tab GNAT XREF -@item Test Manager -@tab HP Digital Test@*Manager (DTM) -@tab HP DTM -@item Performance and@*Coverage Analyzer -@tab HP PCA -@tab HP PCA -@item Module Management@*System -@tab HP MMS -@tab Not applicable -@end multitable -@end flushleft -@end ifnottex +@b{begin} + P2; +@b{end} STB; +@end smallexample -@end ifset +@c ****************************** @c ************************************** @node Platform-Specific Information for the Run-Time Libraries @@ -24508,11 +22101,11 @@ Comments have been added for clarification purposes. -- as a unit name in the partition, in which case some other unique -- name is used. -with System; -package ada_main is +@b{with} System; +@b{package} ada_main @b{is} Elab_Final_Code : Integer; - pragma Import (C, Elab_Final_Code, "__gnat_inside_elab_final_code"); + @b{pragma} Import (C, Elab_Final_Code, "__gnat_inside_elab_final_code"); -- The main program saves the parameters (argument count, -- argument values, environment pointer) in global variables @@ -24527,53 +22120,53 @@ package ada_main is -- is useful for some shared library situations, where there -- are problems if variables are not in the library. - pragma Import (C, gnat_argc); - pragma Import (C, gnat_argv); - pragma Import (C, gnat_envp); + @b{pragma} Import (C, gnat_argc); + @b{pragma} Import (C, gnat_argv); + @b{pragma} Import (C, gnat_envp); -- The exit status is similarly an external location gnat_exit_status : Integer; - pragma Import (C, gnat_exit_status); + @b{pragma} Import (C, gnat_exit_status); - GNAT_Version : constant String := + GNAT_Version : @b{constant} String := "GNAT Version: 6.0.0w (20061115)"; - pragma Export (C, GNAT_Version, "__gnat_version"); + @b{pragma} Export (C, GNAT_Version, "__gnat_version"); -- This is the generated adafinal routine that performs -- finalization at the end of execution. In the case where -- Ada is the main program, this main program makes a call -- to adafinal at program termination. - procedure adafinal; - pragma Export (C, adafinal, "adafinal"); + @b{procedure} adafinal; + @b{pragma} Export (C, adafinal, "adafinal"); -- This is the generated adainit routine that performs -- initialization at the start of execution. In the case -- where Ada is the main program, this main program makes -- a call to adainit at program startup. - procedure adainit; - pragma Export (C, adainit, "adainit"); + @b{procedure} adainit; + @b{pragma} Export (C, adainit, "adainit"); -- This routine is called at the start of execution. It is -- a dummy routine that is used by the debugger to breakpoint -- at the start of execution. - procedure Break_Start; - pragma Import (C, Break_Start, "__gnat_break_start"); + @b{procedure} Break_Start; + @b{pragma} Import (C, Break_Start, "__gnat_break_start"); -- This is the actual generated main program (it would be -- suppressed if the no main program switch were used). As -- required by standard system conventions, this program has -- the external name main. - function main + @b{function} main (argc : Integer; argv : System.Address; envp : System.Address) - return Integer; - pragma Export (C, main, "main"); + @b{return} Integer; + @b{pragma} Export (C, main, "main"); -- The following set of constants give the version -- identification values for every unit in the bound @@ -24582,64 +22175,64 @@ package ada_main is -- string that would be returned by use of the -- Body_Version or Version attributes. - type Version_32 is mod 2 ** 32; - u00001 : constant Version_32 := 16#7880BEB3#; - u00002 : constant Version_32 := 16#0D24CBD0#; - u00003 : constant Version_32 := 16#3283DBEB#; - u00004 : constant Version_32 := 16#2359F9ED#; - u00005 : constant Version_32 := 16#664FB847#; - u00006 : constant Version_32 := 16#68E803DF#; - u00007 : constant Version_32 := 16#5572E604#; - u00008 : constant Version_32 := 16#46B173D8#; - u00009 : constant Version_32 := 16#156A40CF#; - u00010 : constant Version_32 := 16#033DABE0#; - u00011 : constant Version_32 := 16#6AB38FEA#; - u00012 : constant Version_32 := 16#22B6217D#; - u00013 : constant Version_32 := 16#68A22947#; - u00014 : constant Version_32 := 16#18CC4A56#; - u00015 : constant Version_32 := 16#08258E1B#; - u00016 : constant Version_32 := 16#367D5222#; - u00017 : constant Version_32 := 16#20C9ECA4#; - u00018 : constant Version_32 := 16#50D32CB6#; - u00019 : constant Version_32 := 16#39A8BB77#; - u00020 : constant Version_32 := 16#5CF8FA2B#; - u00021 : constant Version_32 := 16#2F1EB794#; - u00022 : constant Version_32 := 16#31AB6444#; - u00023 : constant Version_32 := 16#1574B6E9#; - u00024 : constant Version_32 := 16#5109C189#; - u00025 : constant Version_32 := 16#56D770CD#; - u00026 : constant Version_32 := 16#02F9DE3D#; - u00027 : constant Version_32 := 16#08AB6B2C#; - u00028 : constant Version_32 := 16#3FA37670#; - u00029 : constant Version_32 := 16#476457A0#; - u00030 : constant Version_32 := 16#731E1B6E#; - u00031 : constant Version_32 := 16#23C2E789#; - u00032 : constant Version_32 := 16#0F1BD6A1#; - u00033 : constant Version_32 := 16#7C25DE96#; - u00034 : constant Version_32 := 16#39ADFFA2#; - u00035 : constant Version_32 := 16#571DE3E7#; - u00036 : constant Version_32 := 16#5EB646AB#; - u00037 : constant Version_32 := 16#4249379B#; - u00038 : constant Version_32 := 16#0357E00A#; - u00039 : constant Version_32 := 16#3784FB72#; - u00040 : constant Version_32 := 16#2E723019#; - u00041 : constant Version_32 := 16#623358EA#; - u00042 : constant Version_32 := 16#107F9465#; - u00043 : constant Version_32 := 16#6843F68A#; - u00044 : constant Version_32 := 16#63305874#; - u00045 : constant Version_32 := 16#31E56CE1#; - u00046 : constant Version_32 := 16#02917970#; - u00047 : constant Version_32 := 16#6CCBA70E#; - u00048 : constant Version_32 := 16#41CD4204#; - u00049 : constant Version_32 := 16#572E3F58#; - u00050 : constant Version_32 := 16#20729FF5#; - u00051 : constant Version_32 := 16#1D4F93E8#; - u00052 : constant Version_32 := 16#30B2EC3D#; - u00053 : constant Version_32 := 16#34054F96#; - u00054 : constant Version_32 := 16#5A199860#; - u00055 : constant Version_32 := 16#0E7F912B#; - u00056 : constant Version_32 := 16#5760634A#; - u00057 : constant Version_32 := 16#5D851835#; + @b{type} Version_32 @b{is} @b{mod} 2 ** 32; + u00001 : @b{constant} Version_32 := 16#7880BEB3#; + u00002 : @b{constant} Version_32 := 16#0D24CBD0#; + u00003 : @b{constant} Version_32 := 16#3283DBEB#; + u00004 : @b{constant} Version_32 := 16#2359F9ED#; + u00005 : @b{constant} Version_32 := 16#664FB847#; + u00006 : @b{constant} Version_32 := 16#68E803DF#; + u00007 : @b{constant} Version_32 := 16#5572E604#; + u00008 : @b{constant} Version_32 := 16#46B173D8#; + u00009 : @b{constant} Version_32 := 16#156A40CF#; + u00010 : @b{constant} Version_32 := 16#033DABE0#; + u00011 : @b{constant} Version_32 := 16#6AB38FEA#; + u00012 : @b{constant} Version_32 := 16#22B6217D#; + u00013 : @b{constant} Version_32 := 16#68A22947#; + u00014 : @b{constant} Version_32 := 16#18CC4A56#; + u00015 : @b{constant} Version_32 := 16#08258E1B#; + u00016 : @b{constant} Version_32 := 16#367D5222#; + u00017 : @b{constant} Version_32 := 16#20C9ECA4#; + u00018 : @b{constant} Version_32 := 16#50D32CB6#; + u00019 : @b{constant} Version_32 := 16#39A8BB77#; + u00020 : @b{constant} Version_32 := 16#5CF8FA2B#; + u00021 : @b{constant} Version_32 := 16#2F1EB794#; + u00022 : @b{constant} Version_32 := 16#31AB6444#; + u00023 : @b{constant} Version_32 := 16#1574B6E9#; + u00024 : @b{constant} Version_32 := 16#5109C189#; + u00025 : @b{constant} Version_32 := 16#56D770CD#; + u00026 : @b{constant} Version_32 := 16#02F9DE3D#; + u00027 : @b{constant} Version_32 := 16#08AB6B2C#; + u00028 : @b{constant} Version_32 := 16#3FA37670#; + u00029 : @b{constant} Version_32 := 16#476457A0#; + u00030 : @b{constant} Version_32 := 16#731E1B6E#; + u00031 : @b{constant} Version_32 := 16#23C2E789#; + u00032 : @b{constant} Version_32 := 16#0F1BD6A1#; + u00033 : @b{constant} Version_32 := 16#7C25DE96#; + u00034 : @b{constant} Version_32 := 16#39ADFFA2#; + u00035 : @b{constant} Version_32 := 16#571DE3E7#; + u00036 : @b{constant} Version_32 := 16#5EB646AB#; + u00037 : @b{constant} Version_32 := 16#4249379B#; + u00038 : @b{constant} Version_32 := 16#0357E00A#; + u00039 : @b{constant} Version_32 := 16#3784FB72#; + u00040 : @b{constant} Version_32 := 16#2E723019#; + u00041 : @b{constant} Version_32 := 16#623358EA#; + u00042 : @b{constant} Version_32 := 16#107F9465#; + u00043 : @b{constant} Version_32 := 16#6843F68A#; + u00044 : @b{constant} Version_32 := 16#63305874#; + u00045 : @b{constant} Version_32 := 16#31E56CE1#; + u00046 : @b{constant} Version_32 := 16#02917970#; + u00047 : @b{constant} Version_32 := 16#6CCBA70E#; + u00048 : @b{constant} Version_32 := 16#41CD4204#; + u00049 : @b{constant} Version_32 := 16#572E3F58#; + u00050 : @b{constant} Version_32 := 16#20729FF5#; + u00051 : @b{constant} Version_32 := 16#1D4F93E8#; + u00052 : @b{constant} Version_32 := 16#30B2EC3D#; + u00053 : @b{constant} Version_32 := 16#34054F96#; + u00054 : @b{constant} Version_32 := 16#5A199860#; + u00055 : @b{constant} Version_32 := 16#0E7F912B#; + u00056 : @b{constant} Version_32 := 16#5760634A#; + u00057 : @b{constant} Version_32 := 16#5D851835#; -- The following Export pragmas export the version numbers -- with symbolic names ending in B (for body) or S @@ -24647,63 +22240,63 @@ package ada_main is -- information provided here is sufficient to track down -- the exact versions of units used in a given build. - pragma Export (C, u00001, "helloB"); - pragma Export (C, u00002, "system__standard_libraryB"); - pragma Export (C, u00003, "system__standard_libraryS"); - pragma Export (C, u00004, "adaS"); - pragma Export (C, u00005, "ada__text_ioB"); - pragma Export (C, u00006, "ada__text_ioS"); - pragma Export (C, u00007, "ada__exceptionsB"); - pragma Export (C, u00008, "ada__exceptionsS"); - pragma Export (C, u00009, "gnatS"); - pragma Export (C, u00010, "gnat__heap_sort_aB"); - pragma Export (C, u00011, "gnat__heap_sort_aS"); - pragma Export (C, u00012, "systemS"); - pragma Export (C, u00013, "system__exception_tableB"); - pragma Export (C, u00014, "system__exception_tableS"); - pragma Export (C, u00015, "gnat__htableB"); - pragma Export (C, u00016, "gnat__htableS"); - pragma Export (C, u00017, "system__exceptionsS"); - pragma Export (C, u00018, "system__machine_state_operationsB"); - pragma Export (C, u00019, "system__machine_state_operationsS"); - pragma Export (C, u00020, "system__machine_codeS"); - pragma Export (C, u00021, "system__storage_elementsB"); - pragma Export (C, u00022, "system__storage_elementsS"); - pragma Export (C, u00023, "system__secondary_stackB"); - pragma Export (C, u00024, "system__secondary_stackS"); - pragma Export (C, u00025, "system__parametersB"); - pragma Export (C, u00026, "system__parametersS"); - pragma Export (C, u00027, "system__soft_linksB"); - pragma Export (C, u00028, "system__soft_linksS"); - pragma Export (C, u00029, "system__stack_checkingB"); - pragma Export (C, u00030, "system__stack_checkingS"); - pragma Export (C, u00031, "system__tracebackB"); - pragma Export (C, u00032, "system__tracebackS"); - pragma Export (C, u00033, "ada__streamsS"); - pragma Export (C, u00034, "ada__tagsB"); - pragma Export (C, u00035, "ada__tagsS"); - pragma Export (C, u00036, "system__string_opsB"); - pragma Export (C, u00037, "system__string_opsS"); - pragma Export (C, u00038, "interfacesS"); - pragma Export (C, u00039, "interfaces__c_streamsB"); - pragma Export (C, u00040, "interfaces__c_streamsS"); - pragma Export (C, u00041, "system__file_ioB"); - pragma Export (C, u00042, "system__file_ioS"); - pragma Export (C, u00043, "ada__finalizationB"); - pragma Export (C, u00044, "ada__finalizationS"); - pragma Export (C, u00045, "system__finalization_rootB"); - pragma Export (C, u00046, "system__finalization_rootS"); - pragma Export (C, u00047, "system__finalization_implementationB"); - pragma Export (C, u00048, "system__finalization_implementationS"); - pragma Export (C, u00049, "system__string_ops_concat_3B"); - pragma Export (C, u00050, "system__string_ops_concat_3S"); - pragma Export (C, u00051, "system__stream_attributesB"); - pragma Export (C, u00052, "system__stream_attributesS"); - pragma Export (C, u00053, "ada__io_exceptionsS"); - pragma Export (C, u00054, "system__unsigned_typesS"); - pragma Export (C, u00055, "system__file_control_blockS"); - pragma Export (C, u00056, "ada__finalization__list_controllerB"); - pragma Export (C, u00057, "ada__finalization__list_controllerS"); + @b{pragma} Export (C, u00001, "helloB"); + @b{pragma} Export (C, u00002, "system__standard_libraryB"); + @b{pragma} Export (C, u00003, "system__standard_libraryS"); + @b{pragma} Export (C, u00004, "adaS"); + @b{pragma} Export (C, u00005, "ada__text_ioB"); + @b{pragma} Export (C, u00006, "ada__text_ioS"); + @b{pragma} Export (C, u00007, "ada__exceptionsB"); + @b{pragma} Export (C, u00008, "ada__exceptionsS"); + @b{pragma} Export (C, u00009, "gnatS"); + @b{pragma} Export (C, u00010, "gnat__heap_sort_aB"); + @b{pragma} Export (C, u00011, "gnat__heap_sort_aS"); + @b{pragma} Export (C, u00012, "systemS"); + @b{pragma} Export (C, u00013, "system__exception_tableB"); + @b{pragma} Export (C, u00014, "system__exception_tableS"); + @b{pragma} Export (C, u00015, "gnat__htableB"); + @b{pragma} Export (C, u00016, "gnat__htableS"); + @b{pragma} Export (C, u00017, "system__exceptionsS"); + @b{pragma} Export (C, u00018, "system__machine_state_operationsB"); + @b{pragma} Export (C, u00019, "system__machine_state_operationsS"); + @b{pragma} Export (C, u00020, "system__machine_codeS"); + @b{pragma} Export (C, u00021, "system__storage_elementsB"); + @b{pragma} Export (C, u00022, "system__storage_elementsS"); + @b{pragma} Export (C, u00023, "system__secondary_stackB"); + @b{pragma} Export (C, u00024, "system__secondary_stackS"); + @b{pragma} Export (C, u00025, "system__parametersB"); + @b{pragma} Export (C, u00026, "system__parametersS"); + @b{pragma} Export (C, u00027, "system__soft_linksB"); + @b{pragma} Export (C, u00028, "system__soft_linksS"); + @b{pragma} Export (C, u00029, "system__stack_checkingB"); + @b{pragma} Export (C, u00030, "system__stack_checkingS"); + @b{pragma} Export (C, u00031, "system__tracebackB"); + @b{pragma} Export (C, u00032, "system__tracebackS"); + @b{pragma} Export (C, u00033, "ada__streamsS"); + @b{pragma} Export (C, u00034, "ada__tagsB"); + @b{pragma} Export (C, u00035, "ada__tagsS"); + @b{pragma} Export (C, u00036, "system__string_opsB"); + @b{pragma} Export (C, u00037, "system__string_opsS"); + @b{pragma} Export (C, u00038, "interfacesS"); + @b{pragma} Export (C, u00039, "interfaces__c_streamsB"); + @b{pragma} Export (C, u00040, "interfaces__c_streamsS"); + @b{pragma} Export (C, u00041, "system__file_ioB"); + @b{pragma} Export (C, u00042, "system__file_ioS"); + @b{pragma} Export (C, u00043, "ada__finalizationB"); + @b{pragma} Export (C, u00044, "ada__finalizationS"); + @b{pragma} Export (C, u00045, "system__finalization_rootB"); + @b{pragma} Export (C, u00046, "system__finalization_rootS"); + @b{pragma} Export (C, u00047, "system__finalization_implementationB"); + @b{pragma} Export (C, u00048, "system__finalization_implementationS"); + @b{pragma} Export (C, u00049, "system__string_ops_concat_3B"); + @b{pragma} Export (C, u00050, "system__string_ops_concat_3S"); + @b{pragma} Export (C, u00051, "system__stream_attributesB"); + @b{pragma} Export (C, u00052, "system__stream_attributesS"); + @b{pragma} Export (C, u00053, "ada__io_exceptionsS"); + @b{pragma} Export (C, u00054, "system__unsigned_typesS"); + @b{pragma} Export (C, u00055, "system__file_control_blockS"); + @b{pragma} Export (C, u00056, "ada__finalization__list_controllerB"); + @b{pragma} Export (C, u00057, "ada__finalization__list_controllerS"); -- BEGIN ELABORATION ORDER -- ada (spec) @@ -24765,92 +22358,92 @@ package ada_main is -- hello (body) -- END ELABORATION ORDER -end ada_main; +@b{end} ada_main; -- The following source file name pragmas allow the generated file -- names to be unique for different main programs. They are needed -- since the package name will always be Ada_Main. -pragma Source_File_Name (ada_main, Spec_File_Name => "b~hello.ads"); -pragma Source_File_Name (ada_main, Body_File_Name => "b~hello.adb"); +@b{pragma} Source_File_Name (ada_main, Spec_File_Name => "b~hello.ads"); +@b{pragma} Source_File_Name (ada_main, Body_File_Name => "b~hello.adb"); -- Generated package body for Ada_Main starts here -package body ada_main is +@b{package} @b{body} ada_main @b{is} -- The actual finalization is performed by calling the -- library routine in System.Standard_Library.Adafinal - procedure Do_Finalize; - pragma Import (C, Do_Finalize, "system__standard_library__adafinal"); + @b{procedure} Do_Finalize; + @b{pragma} Import (C, Do_Finalize, "system__standard_library__adafinal"); ------------- -- adainit -- ------------- @findex adainit - procedure adainit is + @b{procedure} adainit @b{is} -- These booleans are set to True once the associated unit has -- been elaborated. It is also used to avoid elaborating the -- same unit twice. E040 : Boolean; - pragma Import (Ada, E040, "interfaces__c_streams_E"); + @b{pragma} Import (Ada, E040, "interfaces__c_streams_E"); E008 : Boolean; - pragma Import (Ada, E008, "ada__exceptions_E"); + @b{pragma} Import (Ada, E008, "ada__exceptions_E"); E014 : Boolean; - pragma Import (Ada, E014, "system__exception_table_E"); + @b{pragma} Import (Ada, E014, "system__exception_table_E"); E053 : Boolean; - pragma Import (Ada, E053, "ada__io_exceptions_E"); + @b{pragma} Import (Ada, E053, "ada__io_exceptions_E"); E017 : Boolean; - pragma Import (Ada, E017, "system__exceptions_E"); + @b{pragma} Import (Ada, E017, "system__exceptions_E"); E024 : Boolean; - pragma Import (Ada, E024, "system__secondary_stack_E"); + @b{pragma} Import (Ada, E024, "system__secondary_stack_E"); E030 : Boolean; - pragma Import (Ada, E030, "system__stack_checking_E"); + @b{pragma} Import (Ada, E030, "system__stack_checking_E"); E028 : Boolean; - pragma Import (Ada, E028, "system__soft_links_E"); + @b{pragma} Import (Ada, E028, "system__soft_links_E"); E035 : Boolean; - pragma Import (Ada, E035, "ada__tags_E"); + @b{pragma} Import (Ada, E035, "ada__tags_E"); E033 : Boolean; - pragma Import (Ada, E033, "ada__streams_E"); + @b{pragma} Import (Ada, E033, "ada__streams_E"); E046 : Boolean; - pragma Import (Ada, E046, "system__finalization_root_E"); + @b{pragma} Import (Ada, E046, "system__finalization_root_E"); E048 : Boolean; - pragma Import (Ada, E048, "system__finalization_implementation_E"); + @b{pragma} Import (Ada, E048, "system__finalization_implementation_E"); E044 : Boolean; - pragma Import (Ada, E044, "ada__finalization_E"); + @b{pragma} Import (Ada, E044, "ada__finalization_E"); E057 : Boolean; - pragma Import (Ada, E057, "ada__finalization__list_controller_E"); + @b{pragma} Import (Ada, E057, "ada__finalization__list_controller_E"); E055 : Boolean; - pragma Import (Ada, E055, "system__file_control_block_E"); + @b{pragma} Import (Ada, E055, "system__file_control_block_E"); E042 : Boolean; - pragma Import (Ada, E042, "system__file_io_E"); + @b{pragma} Import (Ada, E042, "system__file_io_E"); E006 : Boolean; - pragma Import (Ada, E006, "ada__text_io_E"); + @b{pragma} Import (Ada, E006, "ada__text_io_E"); -- Set_Globals is a library routine that stores away the -- value of the indicated set of global values in global -- variables within the library. - procedure Set_Globals + @b{procedure} Set_Globals (Main_Priority : Integer; Time_Slice_Value : Integer; WC_Encoding : Character; @@ -24861,7 +22454,7 @@ package body ada_main is Unreserve_All_Interrupts : Integer; Exception_Tracebacks : Integer); @findex __gnat_set_globals - pragma Import (C, Set_Globals, "__gnat_set_globals"); + @b{pragma} Import (C, Set_Globals, "__gnat_set_globals"); -- SDP_Table_Build is a library routine used to build the -- exception tables. See unit Ada.Exceptions in files @@ -24872,17 +22465,17 @@ package body ada_main is @findex SDP_Table_Build @findex Zero Cost Exceptions - procedure SDP_Table_Build + @b{procedure} SDP_Table_Build (SDP_Addresses : System.Address; SDP_Count : Natural; Elab_Addresses : System.Address; Elab_Addr_Count : Natural); - pragma Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); + @b{pragma} Import (C, SDP_Table_Build, "__gnat_SDP_Table_Build"); -- Table of Unit_Exception_Table addresses. Used for zero -- cost exception handling to build the top level table. - ST : aliased constant array (1 .. 23) of System.Address := ( + ST : @b{aliased} @b{constant} @b{array} (1 .. 23) @b{of} System.Address := ( Hello'UET_Address, Ada.Text_Io'UET_Address, Ada.Exceptions'UET_Address, @@ -24912,7 +22505,7 @@ package body ada_main is -- addresses are included in the top level procedure -- address table. - EA : aliased constant array (1 .. 23) of System.Address := ( + EA : @b{aliased} @b{constant} @b{array} (1 .. 23) @b{of} System.Address := ( adainit'Code_Address, Do_Finalize'Code_Address, Ada.Exceptions'Elab_Spec'Address, @@ -24939,7 +22532,7 @@ package body ada_main is -- Start of processing for adainit - begin + @b{begin} -- Call SDP_Table_Build to build the top level procedure -- table for zero cost exception handling (omitted in @@ -24993,99 +22586,99 @@ package body ada_main is -- implicit elaboration procedures generated by the compiler for -- each unit that requires elaboration. - if not E040 then + @b{if} @b{not} E040 @b{then} Interfaces.C_Streams'Elab_Spec; - end if; + @b{end} @b{if}; E040 := True; - if not E008 then + @b{if} @b{not} E008 @b{then} Ada.Exceptions'Elab_Spec; - end if; - if not E014 then + @b{end} @b{if}; + @b{if} @b{not} E014 @b{then} System.Exception_Table'Elab_Body; E014 := True; - end if; - if not E053 then + @b{end} @b{if}; + @b{if} @b{not} E053 @b{then} Ada.Io_Exceptions'Elab_Spec; E053 := True; - end if; - if not E017 then + @b{end} @b{if}; + @b{if} @b{not} E017 @b{then} System.Exceptions'Elab_Spec; E017 := True; - end if; - if not E030 then + @b{end} @b{if}; + @b{if} @b{not} E030 @b{then} System.Stack_Checking'Elab_Spec; - end if; - if not E028 then + @b{end} @b{if}; + @b{if} @b{not} E028 @b{then} System.Soft_Links'Elab_Body; E028 := True; - end if; + @b{end} @b{if}; E030 := True; - if not E024 then + @b{if} @b{not} E024 @b{then} System.Secondary_Stack'Elab_Body; E024 := True; - end if; - if not E035 then + @b{end} @b{if}; + @b{if} @b{not} E035 @b{then} Ada.Tags'Elab_Spec; - end if; - if not E035 then + @b{end} @b{if}; + @b{if} @b{not} E035 @b{then} Ada.Tags'Elab_Body; E035 := True; - end if; - if not E033 then + @b{end} @b{if}; + @b{if} @b{not} E033 @b{then} Ada.Streams'Elab_Spec; E033 := True; - end if; - if not E046 then + @b{end} @b{if}; + @b{if} @b{not} E046 @b{then} System.Finalization_Root'Elab_Spec; - end if; + @b{end} @b{if}; E046 := True; - if not E008 then + @b{if} @b{not} E008 @b{then} Ada.Exceptions'Elab_Body; E008 := True; - end if; - if not E048 then + @b{end} @b{if}; + @b{if} @b{not} E048 @b{then} System.Finalization_Implementation'Elab_Spec; - end if; - if not E048 then + @b{end} @b{if}; + @b{if} @b{not} E048 @b{then} System.Finalization_Implementation'Elab_Body; E048 := True; - end if; - if not E044 then + @b{end} @b{if}; + @b{if} @b{not} E044 @b{then} Ada.Finalization'Elab_Spec; - end if; + @b{end} @b{if}; E044 := True; - if not E057 then + @b{if} @b{not} E057 @b{then} Ada.Finalization.List_Controller'Elab_Spec; - end if; + @b{end} @b{if}; E057 := True; - if not E055 then + @b{if} @b{not} E055 @b{then} System.File_Control_Block'Elab_Spec; E055 := True; - end if; - if not E042 then + @b{end} @b{if}; + @b{if} @b{not} E042 @b{then} System.File_Io'Elab_Body; E042 := True; - end if; - if not E006 then + @b{end} @b{if}; + @b{if} @b{not} E006 @b{then} Ada.Text_Io'Elab_Spec; - end if; - if not E006 then + @b{end} @b{if}; + @b{if} @b{not} E006 @b{then} Ada.Text_Io'Elab_Body; E006 := True; - end if; + @b{end} @b{if}; Elab_Final_Code := 0; - end adainit; + @b{end} adainit; -------------- -- adafinal -- -------------- @findex adafinal - procedure adafinal is - begin + @b{procedure} adafinal @b{is} + @b{begin} Do_Finalize; - end adafinal; + @b{end} adafinal; ---------- -- main -- @@ -25097,12 +22690,12 @@ package body ada_main is -- pointer. @findex Main Program - function main + @b{function} main (argc : Integer; argv : System.Address; envp : System.Address) - return Integer - is + @b{return} Integer + @b{is} -- The initialize routine performs low level system -- initialization using a standard library routine which -- sets up signal handling and performs any other @@ -25110,8 +22703,8 @@ package body ada_main is -- a-init.c. @findex __gnat_initialize - procedure initialize; - pragma Import (C, initialize, "__gnat_initialize"); + @b{procedure} initialize; + @b{pragma} Import (C, initialize, "__gnat_initialize"); -- The finalize routine performs low level system -- finalization using a standard library routine. The @@ -25120,8 +22713,8 @@ package body ada_main is -- really this is a hook for special user finalization. @findex __gnat_finalize - procedure finalize; - pragma Import (C, finalize, "__gnat_finalize"); + @b{procedure} finalize; + @b{pragma} Import (C, finalize, "__gnat_finalize"); -- We get to the main program of the partition by using -- pragma Import because if we try to with the unit and @@ -25130,12 +22723,12 @@ package body ada_main is -- switches (e.g.@: identifier character set) to be used -- to compile it. - procedure Ada_Main_Program; - pragma Import (Ada, Ada_Main_Program, "_ada_hello"); + @b{procedure} Ada_Main_Program; + @b{pragma} Import (Ada, Ada_Main_Program, "_ada_hello"); -- Start of processing for main - begin + @b{begin} -- Save global variables gnat_argc := argc; @@ -25168,8 +22761,8 @@ package body ada_main is Finalize; -- Return the proper exit status - return (gnat_exit_status); - end; + @b{return} (gnat_exit_status); + @b{end}; -- This section is entirely comments, so it has no effect on the -- compilation of the Ada_Main package. It provides the list of @@ -25191,7 +22784,7 @@ package body ada_main is -- /usr/local/gnat/lib/gcc-lib/i686-pc-linux-gnu/2.8.1/adalib/libgnat.a -- END Object file/option list -end ada_main; +@b{end} ada_main; @end smallexample @noindent @@ -25297,8 +22890,8 @@ of that unit before elaborating the unit doing the @code{with}'ing: @smallexample @c ada @group @cartouche -with Unit_1; -package Unit_2 is @dots{} +@b{with} Unit_1; +@b{package} Unit_2 @b{is} @dots{} @end cartouche @end group @end smallexample @@ -25331,9 +22924,9 @@ The elaboration code of the body of @code{Unit_1} also contains: @smallexample @c ada @group @cartouche -if expression_1 = 1 then +@b{if} expression_1 = 1 @b{then} Q := Unit_2.Func_2; -end if; +@b{end} @b{if}; @end cartouche @end group @end smallexample @@ -25356,9 +22949,9 @@ The elaboration code of the body of @code{Unit_2} also contains: @smallexample @c ada @group @cartouche -if expression_2 = 2 then +@b{if} expression_2 = 2 @b{then} Q := Unit_1.Func_1; -end if; +@b{end} @b{if}; @end cartouche @end group @end smallexample @@ -25519,14 +23112,14 @@ Thus if we have a such a package, as in: @smallexample @c ada @group @cartouche -package Definitions is - generic - type m is new integer; - package Subp is - type a is array (1 .. 10) of m; - type b is array (1 .. 20) of m; - end Subp; -end Definitions; +@b{package} Definitions @b{is} + @b{generic} + @b{type} m @b{is} @b{new} integer; + @b{package} Subp @b{is} + @b{type} a @b{is} @b{array} (1 .. 10) @b{of} m; + @b{type} b @b{is} @b{array} (1 .. 20) @b{of} m; + @b{end} Subp; +@b{end} Definitions; @end cartouche @end group @end smallexample @@ -25738,14 +23331,14 @@ example writing: @smallexample @c ada @group @cartouche -function One return Float; +@b{function} One @b{return} Float; Q : Float := One; -function One return Float is -begin - return 1.0; -end One; +@b{function} One @b{return} Float @b{is} +@b{begin} + @b{return} 1.0; +@b{end} One; @end cartouche @end group @end smallexample @@ -25795,12 +23388,12 @@ would prevent this reordering, and if we write: @smallexample @c ada @group @cartouche -function One return Float; +@b{function} One @b{return} Float; -function One return Float is -begin - return 1.0; -end One; +@b{function} One @b{return} Float @b{is} +@b{begin} + @b{return} 1.0; +@b{end} One; Q : Float := One; @end cartouche @@ -25816,16 +23409,16 @@ Things are more complicated when a chain of subprograms is executed: @smallexample @c ada @group @cartouche -function A return Integer; -function B return Integer; -function C return Integer; +@b{function} A @b{return} Integer; +@b{function} B @b{return} Integer; +@b{function} C @b{return} Integer; -function B return Integer is begin return A; end; -function C return Integer is begin return B; end; +@b{function} B @b{return} Integer @b{is} @b{begin} @b{return} A; @b{end}; +@b{function} C @b{return} Integer @b{is} @b{begin} @b{return} B; @b{end}; X : Integer := C; -function A return Integer is begin return 1; end; +@b{function} A @b{return} Integer @b{is} @b{begin} @b{return} 1; @b{end}; @end cartouche @end group @end smallexample @@ -25881,14 +23474,14 @@ For example, if the body of @code{B} said @smallexample @c ada @group @cartouche -function B return Integer is -begin - if some-condition-depending-on-input-data then - return A; - else - return 1; - end if; -end B; +@b{function} B @b{return} Integer @b{is} +@b{begin} + @b{if} some-condition-depending-on-input-data @b{then} + @b{return} A; + @b{else} + @b{return} 1; + @b{end} @b{if}; +@b{end} B; @end cartouche @end group @end smallexample @@ -25950,28 +23543,28 @@ Consider the following: @smallexample @c ada @cartouche @group -package Math is - function Sqrt (Arg : Float) return Float; -end Math; +@b{package} Math @b{is} + @b{function} Sqrt (Arg : Float) @b{return} Float; +@b{end} Math; -package body Math is - function Sqrt (Arg : Float) return Float is - begin +@b{package} @b{body} Math @b{is} + @b{function} Sqrt (Arg : Float) @b{return} Float @b{is} + @b{begin} @dots{} - end Sqrt; -end Math; + @b{end} Sqrt; +@b{end} Math; @end group @group -with Math; -package Stuff is +@b{with} Math; +@b{package} Stuff @b{is} X : Float := Math.Sqrt (0.5); -end Stuff; +@b{end} Stuff; -with Stuff; -procedure Main is -begin +@b{with} Stuff; +@b{procedure} Main @b{is} +@b{begin} @dots{} -end Main; +@b{end} Main; @end group @end cartouche @end smallexample @@ -26017,15 +23610,15 @@ that is not a general rule that can be followed in all cases. Consider @smallexample @c ada @group @cartouche -package X is @dots{} +@b{package} X @b{is} @dots{} -package Y is @dots{} +@b{package} Y @b{is} @dots{} -with X; -package body Y is @dots{} +@b{with} X; +@b{package} @b{body} Y @b{is} @dots{} -with Y; -package body X is @dots{} +@b{with} Y; +@b{package} @b{body} X @b{is} @dots{} @end cartouche @end group @end smallexample @@ -26107,10 +23700,10 @@ Consider the following source program: @smallexample @c ada @group @cartouche -with k; -package j is +@b{with} k; +@b{package} j @b{is} m : integer := k.r; -end; +@b{end}; @end cartouche @end group @end smallexample @@ -26164,7 +23757,7 @@ the @option{-gnatE} switch on the compiler (@command{gcc} or @command{gnatmake}) command, or by the use of the configuration pragma: @smallexample @c ada -pragma Elaboration_Checks (DYNAMIC); +@b{pragma} Elaboration_Checks (DYNAMIC); @end smallexample @noindent @@ -26253,48 +23846,48 @@ This can definitely result in unexpected circularities. Consider the following example @smallexample @c ada -package Decls is - task Lib_Task is - entry Start; - end Lib_Task; +@b{package} Decls @b{is} + @b{task} Lib_Task @b{is} + @b{entry} Start; + @b{end} Lib_Task; - type My_Int is new Integer; + @b{type} My_Int @b{is} @b{new} Integer; - function Ident (M : My_Int) return My_Int; -end Decls; + @b{function} Ident (M : My_Int) @b{return} My_Int; +@b{end} Decls; -with Utils; -package body Decls is - task body Lib_Task is - begin - accept Start; +@b{with} Utils; +@b{package} @b{body} Decls @b{is} + @b{task} @b{body} Lib_Task @b{is} + @b{begin} + @b{accept} Start; Utils.Put_Val (2); - end Lib_Task; - - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; -end Decls; - -with Decls; -package Utils is - procedure Put_Val (Arg : Decls.My_Int); -end Utils; - -with Text_IO; -package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin + @b{end} Lib_Task; + + @b{function} Ident (M : My_Int) @b{return} My_Int @b{is} + @b{begin} + @b{return} M; + @b{end} Ident; +@b{end} Decls; + +@b{with} Decls; +@b{package} Utils @b{is} + @b{procedure} Put_Val (Arg : Decls.My_Int); +@b{end} Utils; + +@b{with} Text_IO; +@b{package} @b{body} Utils @b{is} + @b{procedure} Put_Val (Arg : Decls.My_Int) @b{is} + @b{begin} Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); - end Put_Val; -end Utils; + @b{end} Put_Val; +@b{end} Utils; -with Decls; -procedure Main is -begin +@b{with} Decls; +@b{procedure} Main @b{is} +@b{begin} Decls.Lib_Task.Start; -end; +@b{end}; @end smallexample @noindent @@ -26396,52 +23989,52 @@ other declarations as much as possible. Let us look at a variation on the above program. @smallexample @c ada -package Decls1 is - task Lib_Task is - entry Start; - end Lib_Task; -end Decls1; - -with Utils; -package body Decls1 is - task body Lib_Task is - begin - accept Start; +@b{package} Decls1 @b{is} + @b{task} Lib_Task @b{is} + @b{entry} Start; + @b{end} Lib_Task; +@b{end} Decls1; + +@b{with} Utils; +@b{package} @b{body} Decls1 @b{is} + @b{task} @b{body} Lib_Task @b{is} + @b{begin} + @b{accept} Start; Utils.Put_Val (2); - end Lib_Task; -end Decls1; - -package Decls2 is - type My_Int is new Integer; - function Ident (M : My_Int) return My_Int; -end Decls2; - -with Utils; -package body Decls2 is - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; -end Decls2; - -with Decls2; -package Utils is - procedure Put_Val (Arg : Decls2.My_Int); -end Utils; - -with Text_IO; -package body Utils is - procedure Put_Val (Arg : Decls2.My_Int) is - begin + @b{end} Lib_Task; +@b{end} Decls1; + +@b{package} Decls2 @b{is} + @b{type} My_Int @b{is} @b{new} Integer; + @b{function} Ident (M : My_Int) @b{return} My_Int; +@b{end} Decls2; + +@b{with} Utils; +@b{package} @b{body} Decls2 @b{is} + @b{function} Ident (M : My_Int) @b{return} My_Int @b{is} + @b{begin} + @b{return} M; + @b{end} Ident; +@b{end} Decls2; + +@b{with} Decls2; +@b{package} Utils @b{is} + @b{procedure} Put_Val (Arg : Decls2.My_Int); +@b{end} Utils; + +@b{with} Text_IO; +@b{package} @b{body} Utils @b{is} + @b{procedure} Put_Val (Arg : Decls2.My_Int) @b{is} + @b{begin} Text_IO.Put_Line (Decls2.My_Int'Image (Decls2.Ident (Arg))); - end Put_Val; -end Utils; + @b{end} Put_Val; +@b{end} Utils; -with Decls1; -procedure Main is -begin +@b{with} Decls1; +@b{procedure} Main @b{is} +@b{begin} Decls1.Lib_Task.Start; -end; +@b{end}; @end smallexample @noindent @@ -26463,53 +24056,53 @@ packages from the task type declaration, many elaboration problems are avoided. Here is another modified example of the example program: @smallexample @c ada -package Decls is - task type Lib_Task_Type is - entry Start; - end Lib_Task_Type; +@b{package} Decls @b{is} + @b{task} @b{type} Lib_Task_Type @b{is} + @b{entry} Start; + @b{end} Lib_Task_Type; - type My_Int is new Integer; + @b{type} My_Int @b{is} @b{new} Integer; - function Ident (M : My_Int) return My_Int; -end Decls; + @b{function} Ident (M : My_Int) @b{return} My_Int; +@b{end} Decls; -with Utils; -package body Decls is - task body Lib_Task_Type is - begin - accept Start; +@b{with} Utils; +@b{package} @b{body} Decls @b{is} + @b{task} @b{body} Lib_Task_Type @b{is} + @b{begin} + @b{accept} Start; Utils.Put_Val (2); - end Lib_Task_Type; - - function Ident (M : My_Int) return My_Int is - begin - return M; - end Ident; -end Decls; - -with Decls; -package Utils is - procedure Put_Val (Arg : Decls.My_Int); -end Utils; - -with Text_IO; -package body Utils is - procedure Put_Val (Arg : Decls.My_Int) is - begin + @b{end} Lib_Task_Type; + + @b{function} Ident (M : My_Int) @b{return} My_Int @b{is} + @b{begin} + @b{return} M; + @b{end} Ident; +@b{end} Decls; + +@b{with} Decls; +@b{package} Utils @b{is} + @b{procedure} Put_Val (Arg : Decls.My_Int); +@b{end} Utils; + +@b{with} Text_IO; +@b{package} @b{body} Utils @b{is} + @b{procedure} Put_Val (Arg : Decls.My_Int) @b{is} + @b{begin} Text_IO.Put_Line (Decls.My_Int'Image (Decls.Ident (Arg))); - end Put_Val; -end Utils; + @b{end} Put_Val; +@b{end} Utils; -with Decls; -package Declst is +@b{with} Decls; +@b{package} Declst @b{is} Lib_Task : Decls.Lib_Task_Type; -end Declst; +@b{end} Declst; -with Declst; -procedure Main is -begin +@b{with} Declst; +@b{procedure} Main @b{is} +@b{begin} Declst.Lib_Task.Start; -end; +@b{end}; @end smallexample @noindent @@ -26760,51 +24353,51 @@ require increasing programmer care in their application. Consider the following program: @smallexample @c adanocomment -package Pack1 is - function F1 return Integer; +@b{package} Pack1 @b{is} + @b{function} F1 @b{return} Integer; X1 : Integer; -end Pack1; +@b{end} Pack1; -package Pack2 is - function F2 return Integer; - function Pure (x : integer) return integer; +@b{package} Pack2 @b{is} + @b{function} F2 @b{return} Integer; + @b{function} Pure (x : integer) @b{return} integer; -- pragma Suppress (Elaboration_Check, On => Pure); -- (3) -- pragma Suppress (Elaboration_Check); -- (4) -end Pack2; - -with Pack2; -package body Pack1 is - function F1 return Integer is - begin - return 100; - end F1; +@b{end} Pack2; + +@b{with} Pack2; +@b{package} @b{body} Pack1 @b{is} + @b{function} F1 @b{return} Integer @b{is} + @b{begin} + @b{return} 100; + @b{end} F1; Val : integer := Pack2.Pure (11); -- Elab. call (1) -begin - declare +@b{begin} + @b{declare} -- pragma Suppress(Elaboration_Check, Pack2.F2); -- (1) -- pragma Suppress(Elaboration_Check); -- (2) - begin + @b{begin} X1 := Pack2.F2 + 1; -- Elab. call (2) - end; -end Pack1; - -with Pack1; -package body Pack2 is - function F2 return Integer is - begin - return Pack1.F1; - end F2; - function Pure (x : integer) return integer is - begin - return x ** 3 - 3 * x; - end; -end Pack2; - -with Pack1, Ada.Text_IO; -procedure Proc3 is -begin + @b{end}; +@b{end} Pack1; + +@b{with} Pack1; +@b{package} @b{body} Pack2 @b{is} + @b{function} F2 @b{return} Integer @b{is} + @b{begin} + @b{return} Pack1.F1; + @b{end} F2; + @b{function} Pure (x : integer) @b{return} integer @b{is} + @b{begin} + @b{return} x ** 3 - 3 * x; + @b{end}; +@b{end} Pack2; + +@b{with} Pack1, Ada.Text_IO; +@b{procedure} Proc3 @b{is} +@b{begin} Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101 -end Proc3; +@b{end} Proc3; @end smallexample In the absence of any pragmas, an attempt to bind this program produces the following diagnostics: @@ -26862,7 +24455,7 @@ information messages generated with the @option{-gnatel} switch can be useful) must be used to ensure that the program is free of errors. One switch that is useful in this testing is the -@option{^-p (pessimistic elaboration order)^/PESSIMISTIC_ELABORATION_ORDER^} +@option{-p (pessimistic elaboration order)} switch for @code{gnatbind}. Normally the binder tries to find an order that has the best chance @@ -26965,35 +24558,35 @@ of avoiding elaboration errors, but rather from extra-lingual logic requirements. Consider this example: @smallexample @c ada -with Init_Constants; -package Constants is +@b{with} Init_Constants; +@b{package} Constants @b{is} X : Integer := 0; Y : Integer := 0; -end Constants; +@b{end} Constants; -package Init_Constants is - procedure P; -- require a body -end Init_Constants; +@b{package} Init_Constants @b{is} + @b{procedure} P; --@i{ require a body} +@b{end} Init_Constants; -with Constants; -package body Init_Constants is - procedure P is begin null; end; -begin +@b{with} Constants; +@b{package} @b{body} Init_Constants @b{is} + @b{procedure} P @b{is} @b{begin} @b{null}; @b{end}; +@b{begin} Constants.X := 3; Constants.Y := 4; -end Init_Constants; +@b{end} Init_Constants; -with Constants; -package Calc is +@b{with} Constants; +@b{package} Calc @b{is} Z : Integer := Constants.X + Constants.Y; -end Calc; +@b{end} Calc; -with Calc; -with Text_IO; use Text_IO; -procedure Main is -begin +@b{with} Calc; +@b{with} Text_IO; @b{use} Text_IO; +@b{procedure} Main @b{is} +@b{begin} Put_Line (Calc.Z'Img); -end Main; +@b{end} Main; @end smallexample @noindent @@ -27039,7 +24632,7 @@ this, it is important to specify the order required. In this particular case, that could have been achieved by adding to the spec of Calc: @smallexample @c ada -pragma Elaborate_All (Constants); +@b{pragma} Elaborate_All (Constants); @end smallexample @noindent @@ -27061,7 +24654,7 @@ in which a pragma Elaborate_Body is usually desirable, and GNAT will generate a warning that suggests this addition if it detects this situation. The @code{gnatbind} -@option{^-p^/PESSIMISTIC_ELABORATION^} switch may be useful in smoking +@option{-p} switch may be useful in smoking out problems. This switch causes bodies to be elaborated as late as possible instead of as early as possible. In the example above, it would have forced the choice of the first elaboration order. If you get different results @@ -27318,7 +24911,7 @@ Furthermore, when using Ada 2012's preconditions and other assertion forms, another issue arises. Consider: @smallexample @c ada - procedure P (A, B : Integer) with + @b{procedure} P (A, B : Integer) @b{with} Pre => A + B <= Integer'Last; @end smallexample @@ -27339,7 +24932,7 @@ up to the implementation. The situation is worse in a case such as the following: @smallexample @c ada - procedure Q (A, B, C : Integer) with + @b{procedure} Q (A, B, C : Integer) @b{with} Pre => A + B + C <= Integer'Last; @end smallexample @@ -27401,7 +24994,7 @@ The three modes are: enough, consider the following example: @smallexample @c ada - procedure R (A, B, C, D : Integer) with + @b{procedure} R (A, B, C, D : Integer) @b{with} Pre => (A**2 * B**2) / (C**2 * D**2) <= 10; @end smallexample @@ -27476,7 +25069,7 @@ The pragma has the form @cindex pragma @code{Overflow_Mode} @smallexample @c ada - pragma Overflow_Mode ([General =>] MODE [, [Assertions =>] MODE]); + @b{pragma} Overflow_Mode ([General =>] MODE [, [Assertions =>] MODE]); @end smallexample @noindent @@ -27499,7 +25092,7 @@ are present, then @code{General} applies to expressions outside assertions, and @code{Assertions} applies to expressions within assertions. For example: @smallexample @c ada - pragma Overflow_Mode + @b{pragma} Overflow_Mode (General => Minimized, Assertions => Eliminated); @end smallexample @@ -27548,10 +25141,10 @@ As with the pragma, if only one digit appears then it applies to all cases; if two digits are given, then the first applies outside assertions, and the second within assertions. Thus the equivalent of the example pragma above would be -@option{^-gnato23^/OVERFLOW_CHECKS=23^}. +@option{-gnato23}. If no digits follow the @option{-gnato}, then it is equivalent to -@option{^-gnato11^/OVERFLOW_CHECKS=11^}, +@option{-gnato11}, causing all intermediate operations to be computed using the base type (@code{STRICT} mode). @@ -27702,11 +25295,11 @@ constants to control which code is executed. @smallexample @c ada @group -FP_Initialize_Required : constant Boolean := True; +FP_Initialize_Required : @b{constant} Boolean := True; @dots{} -if FP_Initialize_Required then +@b{if} FP_Initialize_Required @b{then} @dots{} -end if; +@b{end} @b{if}; @end group @end smallexample @@ -27726,11 +25319,11 @@ something like: @smallexample @c ada @group -package Config is - FP_Initialize_Required : constant Boolean := True; - Reset_Available : constant Boolean := False; +@b{package} Config @b{is} + FP_Initialize_Required : @b{constant} Boolean := True; + Reset_Available : @b{constant} Boolean := False; @dots{} -end Config; +@b{end} Config; @end group @end smallexample @@ -27753,9 +25346,9 @@ is active: @smallexample @c ada @group -if Debugging then +@b{if} Debugging @b{then} Put_Line ("got to the first stage!"); -end if; +@b{end} @b{if}; @end group @end smallexample @@ -27764,9 +25357,9 @@ or @smallexample @c ada @group -if Debugging and then Temperature > 999.0 then - raise Temperature_Crazy; -end if; +@b{if} Debugging @b{and} @b{then} Temperature > 999.0 @b{then} + @b{raise} Temperature_Crazy; +@b{end} @b{if}; @end group @end smallexample @@ -27782,14 +25375,14 @@ The use of pragma @code{Assert} is described in example, the last test could be written: @smallexample @c ada -pragma Assert (Temperature <= 999.0, "Temperature Crazy"); +@b{pragma} Assert (Temperature <= 999.0, "Temperature Crazy"); @end smallexample @noindent or simply @smallexample @c ada -pragma Assert (Temperature <= 999.0); +@b{pragma} Assert (Temperature <= 999.0); @end smallexample @noindent @@ -27813,7 +25406,7 @@ For the example above with the @code{Put_Line}, the GNAT-specific pragma @cindex pragma @code{Debug} @smallexample @c ada -pragma Debug (Put_Line ("got to the first stage!")); +@b{pragma} Debug (Put_Line ("got to the first stage!")); @end smallexample @noindent @@ -27849,12 +25442,12 @@ to add a @code{null} statement. @smallexample @c ada @group -if @dots{} then +@b{if} @dots{} @b{then} @dots{} -- some statements -else - pragma Assert (Num_Cases < 10); - null; -end if; +@b{else} + @b{pragma} Assert (Num_Cases < 10); + @b{null}; +@b{end} @b{if}; @end group @end smallexample @@ -27872,19 +25465,19 @@ by conditional constants: @smallexample @c ada @group -if Small_Machine then - declare +@b{if} Small_Machine @b{then} + @b{declare} X : Bit_String (1 .. 10); - begin + @b{begin} @dots{} - end; -else - declare + @b{end}; +@b{else} + @b{declare} X : Large_Bit_String (1 .. 1000); - begin + @b{begin} @dots{} - end; -end if; + @b{end}; +@b{end} @b{if}; @end group @end smallexample @@ -27899,9 +25492,9 @@ that are parameterized by these constants. For example @smallexample @c ada @group -for Rec use - Field1 at 0 range Boolean'Pos (Little_Endian) * 10 .. Bits_Per_Word; -end record; +@b{for} Rec @b{use} + Field1 @b{at} 0 @b{range} Boolean'Pos (Little_Endian) * 10 .. Bits_Per_Word; +@b{end} @b{record}; @end group @end smallexample @@ -27910,9 +25503,9 @@ If @code{Bits_Per_Word} is set to 32, this generates either @smallexample @c ada @group -for Rec use - Field1 at 0 range 0 .. 32; -end record; +@b{for} Rec @b{use} + Field1 @b{at} 0 @b{range} 0 .. 32; +@b{end} @b{record}; @end group @end smallexample @@ -27921,9 +25514,9 @@ for the big endian case, or @smallexample @c ada @group -for Rec use record - Field1 at 0 range 10 .. 32; -end record; +@b{for} Rec @b{use} @b{record} + Field1 @b{at} 0 @b{range} 10 .. 32; +@b{end} @b{record}; @end group @end smallexample @@ -27961,11 +25554,11 @@ to compile with an Ada 95 compiler. Conceptually you want to say: @smallexample @c ada @group -if Ada_2005 then +@b{if} Ada_2005 @b{then} @dots{} neat Ada 2005 code -else +@b{else} @dots{} not quite as neat Ada 95 code -end if; +@b{end} @b{if}; @end group @end smallexample @@ -27981,7 +25574,7 @@ introduced in Ada 2005, it will be illegal in Ada 95.) So instead we write @smallexample @c ada -procedure Insert is separate; +@b{procedure} Insert @b{is} @b{separate}; @end smallexample @noindent @@ -28228,11 +25821,11 @@ the Inline Assembler facility. @smallexample @c ada @group -with System.Machine_Code; use System.Machine_Code; -procedure Nothing is -begin +@b{with} System.Machine_Code; @b{use} System.Machine_Code; +@b{procedure} Nothing @b{is} +@b{begin} Asm ("nop"); -end Nothing; +@b{end} Nothing; @end group @end smallexample @@ -28332,19 +25925,19 @@ statements. @smallexample @c ada @group -with Interfaces; use Interfaces; -with Ada.Text_IO; use Ada.Text_IO; -with System.Machine_Code; use System.Machine_Code; -procedure Get_Flags is +@b{with} Interfaces; @b{use} Interfaces; +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{with} System.Machine_Code; @b{use} System.Machine_Code; +@b{procedure} Get_Flags @b{is} Flags : Unsigned_32; - use ASCII; -begin - Asm ("pushfl" & LF & HT & -- push flags on stack - "popl %%eax" & LF & HT & -- load eax with flags - "movl %%eax, %0", -- store flags in variable + @b{use} ASCII; +@b{begin} + Asm ("pushfl" & LF & HT & --@i{ push flags on stack} + "popl %%eax" & LF & HT & --@i{ load eax with flags} + "movl %%eax, %0", --@i{ store flags in variable} Outputs => Unsigned_32'Asm_Output ("=g", Flags)); Put_Line ("Flags register:" & Flags'Img); -end Get_Flags; +@b{end} Get_Flags; @end group @end smallexample @@ -28476,9 +26069,9 @@ through the @code{%}@emph{n} notation, where @emph{n} is a non-negative integer. Thus in @smallexample @c ada @group -Asm ("pushfl" & LF & HT & -- push flags on stack - "popl %%eax" & LF & HT & -- load eax with flags - "movl %%eax, %0", -- store flags in variable +Asm ("pushfl" & LF & HT & --@i{ push flags on stack} + "popl %%eax" & LF & HT & --@i{ load eax with flags} + "movl %%eax, %0", --@i{ store flags in variable} Outputs => Unsigned_32'Asm_Output ("=g", Flags)); @end group @end smallexample @@ -28502,9 +26095,9 @@ For example: Asm ("movl %%eax, %0" & LF & HT & "movl %%ebx, %1" & LF & HT & "movl %%ecx, %2", - 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 + Outputs => (Unsigned_32'Asm_Output ("=g", Var_A), --@i{ %0 = Var_A} + Unsigned_32'Asm_Output ("=g", Var_B), --@i{ %1 = Var_B} + Unsigned_32'Asm_Output ("=g", Var_C))); --@i{ %2 = Var_C} @end group @end smallexample @noindent @@ -28518,18 +26111,18 @@ variable, instead of including the store instruction explicitly in the @smallexample @c ada @group -with Interfaces; use Interfaces; -with Ada.Text_IO; use Ada.Text_IO; -with System.Machine_Code; use System.Machine_Code; -procedure Get_Flags_2 is +@b{with} Interfaces; @b{use} Interfaces; +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{with} System.Machine_Code; @b{use} System.Machine_Code; +@b{procedure} Get_Flags_2 @b{is} Flags : Unsigned_32; - use ASCII; -begin - Asm ("pushfl" & LF & HT & -- push flags on stack - "popl %%eax", -- save flags in eax + @b{use} ASCII; +@b{begin} + Asm ("pushfl" & LF & HT & --@i{ push flags on stack} + "popl %%eax", --@i{ save flags in eax} Outputs => Unsigned_32'Asm_Output ("=a", Flags)); Put_Line ("Flags register:" & Flags'Img); -end Get_Flags_2; +@b{end} Get_Flags_2; @end group @end smallexample @@ -28556,18 +26149,18 @@ more simply, we could just pop the flags directly into the program variable: @smallexample @c ada @group -with Interfaces; use Interfaces; -with Ada.Text_IO; use Ada.Text_IO; -with System.Machine_Code; use System.Machine_Code; -procedure Get_Flags_3 is +@b{with} Interfaces; @b{use} Interfaces; +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{with} System.Machine_Code; @b{use} System.Machine_Code; +@b{procedure} Get_Flags_3 @b{is} Flags : Unsigned_32; - use ASCII; -begin - Asm ("pushfl" & LF & HT & -- push flags on stack - "pop %0", -- save flags in Flags + @b{use} ASCII; +@b{begin} + Asm ("pushfl" & LF & HT & --@i{ push flags on stack} + "pop %0", --@i{ save flags in Flags} Outputs => Unsigned_32'Asm_Output ("=g", Flags)); Put_Line ("Flags register:" & Flags'Img); -end Get_Flags_3; +@b{end} Get_Flags_3; @end group @end smallexample @@ -28582,28 +26175,28 @@ The program simply increments its input value by 1: @smallexample @c ada @group -with Interfaces; use Interfaces; -with Ada.Text_IO; use Ada.Text_IO; -with System.Machine_Code; use System.Machine_Code; -procedure Increment is +@b{with} Interfaces; @b{use} Interfaces; +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{with} System.Machine_Code; @b{use} System.Machine_Code; +@b{procedure} Increment @b{is} - function Incr (Value : Unsigned_32) return Unsigned_32 is + @b{function} Incr (Value : Unsigned_32) @b{return} Unsigned_32 @b{is} Result : Unsigned_32; - begin + @b{begin} Asm ("incl %0", Outputs => Unsigned_32'Asm_Output ("=a", Result), Inputs => Unsigned_32'Asm_Input ("a", Value)); - return Result; - end Incr; + @b{return} Result; + @b{end} Incr; Value : Unsigned_32; -begin +@b{begin} Value := 5; Put_Line ("Value before is" & Value'Img); Value := Incr (Value); Put_Line ("Value after is" & Value'Img); -end Increment; +@b{end} Increment; @end group @end smallexample @@ -28664,29 +26257,29 @@ Here is the resulting program: @smallexample @c ada @group -with Interfaces; use Interfaces; -with Ada.Text_IO; use Ada.Text_IO; -with System.Machine_Code; use System.Machine_Code; -procedure Increment_2 is +@b{with} Interfaces; @b{use} Interfaces; +@b{with} Ada.Text_IO; @b{use} Ada.Text_IO; +@b{with} System.Machine_Code; @b{use} System.Machine_Code; +@b{procedure} Increment_2 @b{is} - function Incr (Value : Unsigned_32) return Unsigned_32 is + @b{function} Incr (Value : Unsigned_32) @b{return} Unsigned_32 @b{is} Result : Unsigned_32; - begin + @b{begin} Asm ("incl %0", Outputs => Unsigned_32'Asm_Output ("=a", Result), Inputs => Unsigned_32'Asm_Input ("a", Value)); - return Result; - end Incr; - pragma Inline (Increment); + @b{return} Result; + @b{end} Incr; + @b{pragma} Inline (Increment); Value : Unsigned_32; -begin +@b{begin} Value := 5; Put_Line ("Value before is" & Value'Img); Value := Increment (Value); Put_Line ("Value after is" & Value'Img); -end Increment_2; +@b{end} Increment_2; @end group @end smallexample @@ -28824,6 +26417,146 @@ problems. @c END OF INLINE ASSEMBLER CHAPTER @c =============================== + +@c ***************************************** +@c Writing Portable Fixed-Point Declarations +@c ***************************************** +@node Writing Portable Fixed-Point Declarations +@appendix Writing Portable Fixed-Point Declarations +@cindex Fixed-point types (writing portable declarations) + +@noindent +The Ada Reference Manual gives an implementation freedom to choose bounds +that are narrower by @code{Small} from the given bounds. +For example, if we write + +@smallexample @c ada + type F1 is delta 1.0 range -128.0 .. +128.0; +@end smallexample + +@noindent +then the implementation is allowed to choose -128.0 .. +127.0 if it +likes, but is not required to do so. + +This leads to possible portability problems, so let's have a closer +look at this, and figure out how to avoid these problems. + +First, why does this freedom exist, and why would an implementation +take advantage of it? To answer this, take a closer look at the type +declaration for @code{F1} above. If the compiler uses the given bounds, +it would need 9 bits to hold the largest positive value (and typically +that means 16 bits on all machines). But if the implementation chooses +the +127.0 bound then it can fit values of the type in 8 bits. + +Why not make the user write +127.0 if that's what is wanted? +The rationale is that if you are thinking of fixed point +as a kind of ``poor man's floating-point'', then you don't want +to be thinking about the scaled integers that are used in its +representation. Let's take another example: + +@smallexample @c ada + type F2 is delta 2.0**(-15) range -1.0 .. +1.0; +@end smallexample + +@noindent +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 +big for signed 16 bits. The implementation can treat this as: + +@smallexample @c ada + type F2 is delta 2.0**(-15) range -1.0 .. +1.0-(2.0**(-15)); +@end smallexample + +@noindent +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 +dates to Ada 83). + +But the important point is that an implementation is not required +to do this narrowing, so we have a potential portability problem. +We could imagine three types of implementation: + +@enumerate a +@item +those that narrow the range automatically if they can figure +out that the narrower range will allow storage in a smaller machine unit, + +@item +those that will narrow only if forced to by a @code{'Size} clause, and + +@item +those that will never narrow. +@end enumerate + +@noindent +Now if we are language theoreticians, we can imagine a fourth +approach: is to narrow all the time, e.g. to treat + +@smallexample @c ada + type F3 is delta 1.0 range -10.0 .. +23.0; +@end smallexample + +@noindent +as though it had been written: + +@smallexample @c ada + type F3 is delta 1.0 range -9.0 .. +22.0; +@end smallexample + +@noindent +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. + +So, how do you get the compiler to do what you want? The answer is give the +actual bounds you want, and then use a @code{'Small} clause and a +@code{'Size} clause to absolutely pin down what the compiler does. +E.g., for @code{F2} above, we will write: + +@smallexample @c ada +@group + My_Small : constant := 2.0**(-15); + My_First : constant := -1.0; + My_Last : constant := +1.0 - My_Small; + + type F2 is delta My_Small range My_First .. My_Last; +@end group +@end smallexample + +@noindent +and then add + +@smallexample @c ada +@group + for F2'Small use my_Small; + for F2'Size use 16; +@end group +@end smallexample + +@noindent +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 +compiler you could add + +@smallexample @c ada +@group + Test1 : constant := 1 / Boolean'Pos (F2'First = My_First); + Test2 : constant := 1 / Boolean'Pos (F2'Last = My_Last); +@end group +@end smallexample + +@noindent +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. + +If you follow this scheme you will be guaranteed that your fixed-point +types will be portable. + + @c *********************************** @c * Compatibility and Porting Guide * @c *********************************** @@ -28842,14 +26575,9 @@ applications developed in other Ada environments. * Implementation-dependent characteristics:: * Compatibility with Other Ada Systems:: * Representation Clauses:: -@ifclear vms @c Brief section is only in non-VMS version @c Full chapter is in VMS version * Compatibility with HP Ada 83:: -@end ifclear -@ifset vms -* Transitioning to 64-Bit GNAT for OpenVMS:: -@end ifset @end menu @node Compatibility with Ada 83 @@ -28889,7 +26617,7 @@ Some uses of character literals are ambiguous. Since Ada 95 has introduced character literals that were legal in Ada 83 are illegal in Ada 95. For example: @smallexample @c ada - for Char in 'A' .. 'Z' loop @dots{} end loop; + @b{for} Char @b{in} 'A' .. 'Z' @b{loop} @dots{} @b{end} @b{loop}; @end smallexample @noindent @@ -28897,7 +26625,7 @@ The problem is that @code{'A'} and @code{'Z'} could be from either @code{Character} or @code{Wide_Character}. The simplest correction is to make the type explicit; e.g.: @smallexample @c ada - for Char in Character range 'A' .. 'Z' loop @dots{} end loop; + @b{for} Char @b{in} Character @b{range} 'A' .. 'Z' @b{loop} @dots{} @b{end} @b{loop}; @end smallexample @item New reserved words @@ -28915,10 +26643,6 @@ appears too late, and the appropriate corrective action is to move the item nearer to the declaration of the entity to which it refers. A particular case is that representation pragmas -@ifset vms -(including the -extended HP Ada 83 compatibility pragmas such as @code{Export_Procedure}) -@end ifset cannot be applied to a subprogram body. If necessary, a separate subprogram declaration must be introduced to which the pragma can be applied. @@ -29315,8 +27039,8 @@ type). These thin pointers are indeed the same size as a System.Address value. To specify a thin pointer, use a size clause for the type, for example: @smallexample @c ada -type X is access all String; -for X'Size use Standard'Address_Size; +@b{type} X @b{is} @b{access} @b{all} String; +@b{for} X'Size @b{use} Standard'Address_Size; @end smallexample @noindent @@ -29336,7 +27060,6 @@ full discussion of possible problems using this attribute in conjunction with thin pointers. @end table -@ifclear vms @c This brief section is only in the non-VMS version @c The complete chapter on HP Ada is in the VMS version @node Compatibility with HP Ada 83 @@ -29400,12 +27123,12 @@ to change the name of the function in the UNSIGNED_LONGWORD case, so the declarations provided in the GNAT version of AUX_Dec are: @smallexample @c ada -function To_Address (X : Integer) return Address; -pragma Pure_Function (To_Address); +@b{function} To_Address (X : Integer) @b{return} Address; +@b{pragma} Pure_Function (To_Address); -function To_Address_Long (X : Unsigned_Longword) - return Address; -pragma Pure_Function (To_Address_Long); +@b{function} To_Address_Long (X : Unsigned_Longword) + @b{return} Address; +@b{pragma} Pure_Function (To_Address_Long); @end smallexample @noindent @@ -29428,418 +27151,7 @@ attributes are recognized, although only a subset of them can sensibly be implemented. The description of pragmas in @ref{Implementation Defined Pragmas,,, gnat_rm, GNAT Reference Manual} indicates whether or not they are applicable to non-VMS systems. -@end ifclear - -@ifset vms -@node Transitioning to 64-Bit GNAT for OpenVMS -@section Transitioning to 64-Bit @value{EDITION} for OpenVMS - -@noindent -This section is meant to assist users of pre-2006 @value{EDITION} -for Alpha OpenVMS who are transitioning to 64-bit @value{EDITION}, -the version of the GNAT technology supplied in 2006 and later for -OpenVMS on both Alpha and I64. - -@menu -* Introduction to transitioning:: -* Migration of 32 bit code:: -* Taking advantage of 64 bit addressing:: -* Technical details:: -@end menu - -@node Introduction to transitioning -@subsection Introduction - -@noindent -64-bit @value{EDITION} for Open VMS has been designed to meet -three main goals: - -@enumerate -@item -Providing a full conforming implementation of Ada 95 and Ada 2005 - -@item -Allowing maximum backward compatibility, thus easing migration of existing -Ada source code - -@item -Supplying a path for exploiting the full 64-bit address range -@end enumerate - -@noindent -Ada's strong typing semantics has made it -impractical to have different 32-bit and 64-bit modes. As soon as -one object could possibly be outside the 32-bit address space, this -would make it necessary for the @code{System.Address} type to be 64 bits. -In particular, this would cause inconsistencies if 32-bit code is -called from 64-bit code that raises an exception. - -This issue has been resolved by always using 64-bit addressing -at the system level, but allowing for automatic conversions between -32-bit and 64-bit addresses where required. Thus users who -do not currently require 64-bit addressing capabilities, can -recompile their code with only minimal changes (and indeed -if the code is written in portable Ada, with no assumptions about -the size of the @code{Address} type, then no changes at all are necessary). -At the same time, -this approach provides a simple, gradual upgrade path to future -use of larger memories than available for 32-bit systems. -Also, newly written applications or libraries will by default -be fully compatible with future systems exploiting 64-bit -addressing capabilities. - -@ref{Migration of 32 bit code}, will focus on porting applications -that do not require more than 2 GB of -addressable memory. This code will be referred to as -@emph{32-bit code}. -For applications intending to exploit the full 64-bit address space, -@ref{Taking advantage of 64 bit addressing}, -will consider further changes that may be required. -Such code will be referred to below as @emph{64-bit code}. - -@node Migration of 32 bit code -@subsection Migration of 32-bit code - -@menu -* Address types:: -* Access types and 32/64-bit allocation:: -* Unchecked conversions:: -* Predefined constants:: -* Interfacing with C:: -* 32/64-bit descriptors:: -* Experience with source compatibility:: -@end menu - -@node Address types -@subsubsection Address types - -@noindent -To solve the problem of mixing 64-bit and 32-bit addressing, -while maintaining maximum backward compatibility, the following -approach has been taken: - -@itemize @bullet -@item -@code{System.Address} always has a size of 64 bits -@cindex @code{System.Address} size -@cindex @code{Address} size - -@item -@code{System.Short_Address} is a 32-bit subtype of @code{System.Address} -@cindex @code{System.Short_Address} size -@cindex @code{Short_Address} size -@end itemize - -@noindent -Since @code{System.Short_Address} is a subtype of @code{System.Address}, -a @code{Short_Address} -may be used where an @code{Address} is required, and vice versa, without -needing explicit type conversions. -By virtue of the Open VMS parameter passing conventions, -even imported -and exported subprograms that have 32-bit address parameters are -compatible with those that have 64-bit address parameters. -(See @ref{Making code 64 bit clean} for details.) - -The areas that may need attention are those where record types have -been defined that contain components of the type @code{System.Address}, and -where objects of this type are passed to code expecting a record layout with -32-bit addresses. - -Different compilers on different platforms cannot be -expected to represent the same type in the same way, -since alignment constraints -and other system-dependent properties affect the compiler's decision. -For that reason, Ada code -generally uses representation clauses to specify the expected -layout where required. - -If such a representation clause uses 32 bits for a component having -the type @code{System.Address}, 64-bit @value{EDITION} for OpenVMS -will detect that error and produce a specific diagnostic message. -The developer should then determine whether the representation -should be 64 bits or not and make either of two changes: -change the size to 64 bits and leave the type as @code{System.Address}, or -leave the size as 32 bits and change the type to @code{System.Short_Address}. -Since @code{Short_Address} is a subtype of @code{Address}, no changes are -required in any code setting or accessing the field; the compiler will -automatically perform any needed conversions between address -formats. - -@node Access types and 32/64-bit allocation -@subsubsection Access types and 32/64-bit allocation -@cindex 32-bit allocation -@cindex 64-bit allocation - -@noindent -By default, objects designated by access values are always allocated in -the 64-bit address space, and access values themselves are represented -in 64 bits. If these defaults are not appropriate, and 32-bit allocation -is required (for example if the address of an allocated object is assigned -to a @code{Short_Address} variable), then several alternatives are available: - -@itemize @bullet -@item -A pool-specific access type (ie, an @w{Ada 83} access type, whose -definition is @code{access T} versus @code{access all T} or -@code{access constant T}), may be declared with a @code{'Size} representation -clause that establishes the size as 32 bits. -In such circumstances allocations for that type will -be from the 32-bit heap. Such a clause is not permitted -for a general access type (declared with @code{access all} or -@code{access constant}) as values of such types must be able to refer -to any object of the designated type, including objects residing outside -the 32-bit address range. Existing @w{Ada 83} code will not contain such -type definitions, however, since general access types were introduced -in @w{Ada 95}. - -@item -Switches for @command{GNAT BIND} control whether the internal GNAT -allocation routine @code{__gnat_malloc} uses 64-bit or 32-bit allocations. -@cindex @code{__gnat_malloc} -The switches are respectively @option{-H64} (the default) and -@option{-H32}. -@cindex @option{-H32} (@command{gnatbind}) -@cindex @option{-H64} (@command{gnatbind}) - -@item -The environment variable (logical name) @code{GNAT$NO_MALLOC_64} -@cindex @code{GNAT$NO_MALLOC_64} environment variable -may be used to force @code{__gnat_malloc} to use 32-bit allocation. -If this variable is left -undefined, or defined as @code{"DISABLE"}, @code{"FALSE"}, or @code{"0"}, -then the default (64-bit) allocation is used. -If defined as @code{"ENABLE"}, @code{"TRUE"}, or @code{"1"}, -then 32-bit allocation is used. The gnatbind qualifiers described above -override this logical name. - -@item -A ^gcc switch^gcc switch^ for OpenVMS, @option{-mno-malloc64}, operates -@cindex @option{-mno-malloc64} (^gcc^gcc^) -at a low level to convert explicit calls to @code{malloc} and related -functions from the C run-time library so that they perform allocations -in the 32-bit heap. -Since all internal allocations from GNAT use @code{__gnat_malloc}, -this switch is not required unless the program makes explicit calls on -@code{malloc} (or related functions) from interfaced C code. -@end itemize - - -@node Unchecked conversions -@subsubsection Unchecked conversions - -@noindent -In the case of an @code{Unchecked_Conversion} where the source type is a -64-bit access type or the type @code{System.Address}, and the target -type is a 32-bit type, the compiler will generate a warning. -Even though the generated code will still perform the required -conversions, it is highly recommended in these cases to use -respectively a 32-bit access type or @code{System.Short_Address} -as the source type. - -@node Predefined constants -@subsubsection Predefined constants - -@noindent -The following table shows the correspondence between pre-2006 versions of -@value{EDITION} on Alpha OpenVMS (``Old'') and 64-bit @value{EDITION} -(``New''): - -@multitable {@code{System.Short_Memory_Size}} {2**32} {2**64} -@item @b{Constant} @tab @b{Old} @tab @b{New} -@item @code{System.Word_Size} @tab 32 @tab 64 -@item @code{System.Memory_Size} @tab 2**32 @tab 2**64 -@item @code{System.Short_Memory_Size} @tab 2**32 @tab 2**32 -@item @code{System.Address_Size} @tab 32 @tab 64 -@end multitable - -@noindent -If you need to refer to the specific -memory size of a 32-bit implementation, instead of the -actual memory size, use @code{System.Short_Memory_Size} -rather than @code{System.Memory_Size}. -Similarly, references to @code{System.Address_Size} may need -to be replaced by @code{System.Short_Address'Size}. -The program @command{gnatfind} may be useful for locating -references to the above constants, so that you can verify that they -are still correct. - -@node Interfacing with C -@subsubsection Interfacing with C - -@noindent -In order to minimize the impact of the transition to 64-bit addresses on -legacy programs, some fundamental types in the @code{Interfaces.C} -package hierarchy continue to be represented in 32 bits. -These types are: @code{ptrdiff_t}, @code{size_t}, and @code{chars_ptr}. -This eases integration with the default HP C layout choices, for example -as found in the system routines in @code{DECC$SHR.EXE}. -Because of this implementation choice, the type fully compatible with -@code{chars_ptr} is now @code{Short_Address} and not @code{Address}. -Depending on the context the compiler will issue a -warning or an error when type @code{Address} is used, alerting the user to a -potential problem. Otherwise 32-bit programs that use -@code{Interfaces.C} should normally not require code modifications - -The other issue arising with C interfacing concerns pragma @code{Convention}. -For VMS 64-bit systems, there is an issue of the appropriate default size -of C convention pointers in the absence of an explicit size clause. The HP -C compiler can choose either 32 or 64 bits depending on compiler options. -GNAT chooses 32-bits rather than 64-bits in the default case where no size -clause is given. This proves a better choice for porting 32-bit legacy -applications. In order to have a 64-bit representation, it is necessary to -specify a size representation clause. For example: - -@smallexample @c ada -type int_star is access Interfaces.C.int; -pragma Convention(C, int_star); -for int_star'Size use 64; -- Necessary to get 64 and not 32 bits -@end smallexample - -@node 32/64-bit descriptors -@subsubsection 32/64-bit descriptors - -@noindent -By default, GNAT uses a 64-bit descriptor mechanism. For an imported -subprogram (i.e., a subprogram identified by pragma @code{Import_Function}, -@code{Import_Procedure}, or @code{Import_Valued_Procedure}) that specifies -@code{Short_Descriptor} as its mechanism, a 32-bit descriptor is used. -@cindex @code{Short_Descriptor} mechanism for imported subprograms - -If the configuration pragma @code{Short_Descriptors} is supplied, then -all descriptors will be 32 bits. -@cindex pragma @code{Short_Descriptors} - -@node Experience with source compatibility -@subsubsection Experience with source compatibility - -@noindent -The Security Server and STARLET on I64 provide an interesting ``test case'' -for source compatibility issues, since it is in such system code -where assumptions about @code{Address} size might be expected to occur. -Indeed, there were a small number of occasions in the Security Server -file @file{jibdef.ads} -where a representation clause for a record type specified -32 bits for a component of type @code{Address}. -All of these errors were detected by the compiler. -The repair was obvious and immediate; to simply replace @code{Address} by -@code{Short_Address}. - -In the case of STARLET, there were several record types that should -have had representation clauses but did not. In these record types -there was an implicit assumption that an @code{Address} value occupied -32 bits. -These compiled without error, but their usage resulted in run-time error -returns from STARLET system calls. -Future GNAT technology enhancements may include a tool that detects and flags -these sorts of potential source code porting problems. - -@c **************************************** -@node Taking advantage of 64 bit addressing -@subsection Taking advantage of 64-bit addressing - -@menu -* Making code 64 bit clean:: -* Allocating memory from the 64 bit storage pool:: -* Restrictions on use of 64 bit objects:: -* STARLET and other predefined libraries:: -@end menu -@node Making code 64 bit clean -@subsubsection Making code 64-bit clean - -@noindent -In order to prevent problems that may occur when (parts of) a -system start using memory outside the 32-bit address range, -we recommend some additional guidelines: - -@itemize @bullet -@item -For imported subprograms that take parameters of the -type @code{System.Address}, ensure that these subprograms can -indeed handle 64-bit addresses. If not, or when in doubt, -change the subprogram declaration to specify -@code{System.Short_Address} instead. - -@item -Resolve all warnings related to size mismatches in -unchecked conversions. Failing to do so causes -erroneous execution if the source object is outside -the 32-bit address space. - -@item -(optional) Explicitly use the 32-bit storage pool -for access types used in a 32-bit context, or use -generic access types where possible -(@pxref{Restrictions on use of 64 bit objects}). -@end itemize - -@noindent -If these rules are followed, the compiler will automatically insert -any necessary checks to ensure that no addresses or access values -passed to 32-bit code ever refer to objects outside the 32-bit -address range. -Any attempt to do this will raise @code{Constraint_Error}. - -@node Allocating memory from the 64 bit storage pool -@subsubsection Allocating memory from the 64-bit storage pool - -@noindent -By default, all allocations -- for both pool-specific and general -access types -- use the 64-bit storage pool. To override -this default, for an individual access type or globally, see -@ref{Access types and 32/64-bit allocation}. - -@node Restrictions on use of 64 bit objects -@subsubsection Restrictions on use of 64-bit objects - -@noindent -Taking the address of an object allocated from a 64-bit storage pool, -and then passing this address to a subprogram expecting -@code{System.Short_Address}, -or assigning it to a variable of type @code{Short_Address}, will cause -@code{Constraint_Error} to be raised. In case the code is not 64-bit clean -(@pxref{Making code 64 bit clean}), or checks are suppressed, -no exception is raised and execution -will become erroneous. - -@node STARLET and other predefined libraries -@subsubsection STARLET and other predefined libraries - -@noindent -All code that comes as part of GNAT is 64-bit clean, but the -restrictions given in @ref{Restrictions on use of 64 bit objects}, -still apply. Look at the package -specs to see in which contexts objects allocated -in 64-bit address space are acceptable. - -@node Technical details -@subsection Technical details - -@noindent -64-bit @value{EDITION} for Open VMS takes advantage of the freedom given in the -Ada standard with respect to the type of @code{System.Address}. Previous -versions of @value{EDITION} have defined this type as private and implemented it as a -modular type. - -In order to allow defining @code{System.Short_Address} as a proper subtype, -and to match the implicit sign extension in parameter passing, -in 64-bit @value{EDITION} for Open VMS, @code{System.Address} is defined as a -visible (i.e., non-private) integer type. -Standard operations on the type, such as the binary operators ``+'', ``-'', -etc., that take @code{Address} operands and return an @code{Address} result, -have been hidden by declaring these -@code{abstract}, a feature introduced in Ada 95 that helps avoid the potential -ambiguities that would otherwise result from overloading. -(Note that, although @code{Address} is a visible integer type, -good programming practice dictates against exploiting the type's -integer properties such as literals, since this will compromise -code portability.) - -Defining @code{Address} as a visible integer type helps achieve -maximum compatibility for existing Ada code, -without sacrificing the capabilities of the 64-bit architecture. -@end ifset @c ************************************************ @node Microsoft Windows Topics @@ -30184,8 +27496,8 @@ should be imported from Ada as follows: @smallexample @c ada @group -function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; -pragma Import (C, Get_Val, External_Name => "get_val"); +@b{function} Get_Val (V : Interfaces.C.long) @b{return} Interfaces.C.int; +@b{pragma} Import (C, Get_Val, External_Name => "get_val"); @end group @end smallexample @@ -30232,9 +27544,9 @@ should be imported from Ada as follows: @smallexample @c ada @group -function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; -pragma Import (Stdcall, Get_Val); --- On the x86 a long is 4 bytes, so the Link_Name is "_get_val@@4" +@b{function} Get_Val (V : Interfaces.C.long) @b{return} Interfaces.C.int; +@b{pragma} Import (Stdcall, Get_Val); +--@i{ On the x86 a long is 4 bytes, so the Link_Name is "_get_val@@4"} @end group @end smallexample @@ -30245,8 +27557,8 @@ case. If instead of writing the above import pragma you write: @smallexample @c ada @group -function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; -pragma Import (Stdcall, Get_Val, External_Name => "retrieve_val"); +@b{function} Get_Val (V : Interfaces.C.long) @b{return} Interfaces.C.int; +@b{pragma} Import (Stdcall, Get_Val, External_Name => "retrieve_val"); @end group @end smallexample @@ -30257,8 +27569,8 @@ of specifying the @code{External_Name} parameter you specify the @smallexample @c ada @group -function Get_Val (V : Interfaces.C.long) return Interfaces.C.int; -pragma Import (Stdcall, Get_Val, Link_Name => "retrieve_val"); +@b{function} Get_Val (V : Interfaces.C.long) @b{return} Interfaces.C.int; +@b{pragma} Import (Stdcall, Get_Val, Link_Name => "retrieve_val"); @end group @end smallexample @@ -30287,7 +27599,7 @@ then, to access this variable from Ada you should write: @smallexample @c ada @group My_Var : Interfaces.C.int; -pragma Import (Stdcall, My_Var); +@b{pragma} Import (Stdcall, My_Var); @end group @end smallexample @@ -30451,7 +27763,7 @@ Note that if the Ada package spec for @file{API.dll} contains the following pragma @smallexample @c ada -pragma Linker_Options ("-lAPI"); +@b{pragma} Linker_Options ("-lAPI"); @end smallexample @noindent @@ -30489,17 +27801,17 @@ then the equivalent Ada spec could be: @smallexample @c ada @group @cartouche -with Interfaces.C.Strings; -package API is - use Interfaces; +@b{with} Interfaces.C.Strings; +@b{package} API @b{is} + @b{use} Interfaces; Some_Var : C.int; - function Get (Str : C.Strings.Chars_Ptr) return C.int; + @b{function} Get (Str : C.Strings.Chars_Ptr) @b{return} C.int; -private - pragma Import (C, Get); - pragma Import (DLL, Some_Var); -end API; +@b{private} + @b{pragma} Import (C, Get); + @b{pragma} Import (DLL, Some_Var); +@b{end} API; @end cartouche @end group @end smallexample @@ -30858,20 +28170,20 @@ variable: @smallexample @c ada @group @cartouche -with Interfaces.C; use Interfaces; -package API is +@b{with} Interfaces.C; @b{use} Interfaces; +@b{package} API @b{is} Count : C.int := 0; - function Factorial (Val : C.int) return C.int; - - procedure Initialize_API; - procedure Finalize_API; - -- Initialization & Finalization routines. More in the next section. -private - pragma Export (C, Initialize_API); - pragma Export (C, Finalize_API); - pragma Export (C, Count); - pragma Export (C, Factorial); -end API; + @b{function} Factorial (Val : C.int) @b{return} C.int; + + @b{procedure} Initialize_API; + @b{procedure} Finalize_API; + --@i{ Initialization & Finalization routines. More in the next section.} +@b{private} + @b{pragma} Export (C, Initialize_API); + @b{pragma} Export (C, Finalize_API); + @b{pragma} Export (C, Count); + @b{pragma} Export (C, Factorial); +@b{end} API; @end cartouche @end group @end smallexample @@ -30879,31 +28191,31 @@ end API; @smallexample @c ada @group @cartouche -package body API is - function Factorial (Val : C.int) return C.int is +@b{package} @b{body} API @b{is} + @b{function} Factorial (Val : C.int) @b{return} C.int @b{is} Fact : C.int := 1; - begin + @b{begin} Count := Count + 1; - for K in 1 .. Val loop + @b{for} K @b{in} 1 .. Val @b{loop} Fact := Fact * K; - end loop; - return Fact; - end Factorial; - - procedure Initialize_API is - procedure Adainit; - pragma Import (C, Adainit); - begin + @b{end} @b{loop}; + @b{return} Fact; + @b{end} Factorial; + + @b{procedure} Initialize_API @b{is} + @b{procedure} Adainit; + @b{pragma} Import (C, Adainit); + @b{begin} Adainit; - end Initialize_API; + @b{end} Initialize_API; - procedure Finalize_API is - procedure Adafinal; - pragma Import (C, Adafinal); - begin + @b{procedure} Finalize_API @b{is} + @b{procedure} Adafinal; + @b{pragma} Import (C, Adafinal); + @b{begin} Adafinal; - end Finalize_API; -end API; + @b{end} Finalize_API; +@b{end} API; @end cartouche @end group @end smallexample @@ -30917,14 +28229,14 @@ follows: @smallexample @c ada @group @cartouche -package API is +@b{package} API @b{is} Count : Integer := 0; - function Factorial (Val : Integer) return Integer; + @b{function} Factorial (Val : Integer) @b{return} Integer; - procedure Initialize_API; - procedure Finalize_API; - -- Initialization and Finalization routines. -end API; + @b{procedure} Initialize_API; + @b{procedure} Finalize_API; + --@i{ Initialization and Finalization routines.} +@b{end} API; @end cartouche @end group @end smallexample @@ -30932,20 +28244,20 @@ end API; @smallexample @c ada @group @cartouche -package body API is - function Factorial (Val : Integer) return Integer is +@b{package} @b{body} API @b{is} + @b{function} Factorial (Val : Integer) @b{return} Integer @b{is} Fact : Integer := 1; - begin + @b{begin} Count := Count + 1; - for K in 1 .. Val loop + @b{for} K @b{in} 1 .. Val @b{loop} Fact := Fact * K; - end loop; - return Fact; - end Factorial; + @b{end} @b{loop}; + @b{return} Fact; + @b{end} Factorial; @dots{} - -- The remainder of this package body is unchanged. -end API; + --@i{ The remainder of this package body is unchanged.} +@b{end} API; @end cartouche @end group @end smallexample @@ -31032,11 +28344,11 @@ example consider a DLL comprising the following package @code{API}: @smallexample @c ada @group @cartouche -package API is +@b{package} API @b{is} Count : Integer := 0; @dots{} - -- Remainder of the package omitted. -end API; + --@i{ Remainder of the package omitted.} +@b{end} API; @end cartouche @end group @end smallexample @@ -31049,10 +28361,10 @@ DLL is: @smallexample @c ada @group @cartouche -package API is +@b{package} API @b{is} Count : Integer; - pragma Import (DLL, Count); -end API; + @b{pragma} Import (DLL, Count); +@b{end} API; @end cartouche @end group @end smallexample diff --git a/main/gcc/ada/gnatbind.adb b/main/gcc/ada/gnatbind.adb index 6383e818b14..7cba0c684f2 100644 --- a/main/gcc/ada/gnatbind.adb +++ b/main/gcc/ada/gnatbind.adb @@ -77,8 +77,6 @@ procedure Gnatbind is Output_File_Name_Seen : Boolean := False; Output_File_Name : String_Ptr := new String'(""); - L_Switch_Seen : Boolean := False; - Mapping_File : String_Ptr := null; package Closure_Sources is new Table.Table @@ -338,12 +336,6 @@ procedure Gnatbind is elsif Argv (2) = 'L' then if Argv'Length >= 3 then - -- Remember that the -L switch was specified, so that if this - -- is on OpenVMS, the export names are put in uppercase. - -- This is not known before the target parameters are read. - - L_Switch_Seen := True; - Opt.Bind_For_Library := True; Opt.Ada_Init_Name := new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix); @@ -642,17 +634,6 @@ begin Cumulative_Restrictions := Targparm.Restrictions_On_Target; - -- On OpenVMS, when -L is used, all external names used in pragmas Export - -- are in upper case. The reason is that on OpenVMS, the macro-assembler - -- MACASM-32, used to build Stand-Alone Libraries, only understands - -- uppercase. - - if L_Switch_Seen and then OpenVMS_On_Target then - To_Upper (Opt.Ada_Init_Name.all); - To_Upper (Opt.Ada_Final_Name.all); - To_Upper (Opt.Ada_Main_Name.all); - end if; - -- Acquire configurable run-time mode if Configurable_Run_Time_On_Target then diff --git a/main/gcc/ada/gnatchop.adb b/main/gcc/ada/gnatchop.adb index d51e83adf5c..c638c4551b5 100644 --- a/main/gcc/ada/gnatchop.adb +++ b/main/gcc/ada/gnatchop.adb @@ -36,7 +36,6 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Heap_Sort_G; with GNAT.Table; -with Hostparm; with Switch; use Switch; with Types; @@ -256,27 +255,23 @@ procedure Gnatchop is procedure Parse_Offset_Info (Chop_File : File_Num; Source : not null access String); - -- Parses the output of the compiler indicating the offsets - -- and names of the compilation units in Chop_File. + -- Parses the output of the compiler indicating the offsets and names of + -- the compilation units in Chop_File. procedure Parse_Token (Source : not null access String; Ptr : in out Positive; Token_Ptr : out Positive); -- Skips any separators and stores the start of the token in Token_Ptr. - -- Then stores the position of the next separator in Ptr. - -- On return Source (Token_Ptr .. Ptr - 1) is the token. + -- Then stores the position of the next separator in Ptr. On return + -- Source (Token_Ptr .. Ptr - 1) is the token. procedure Read_File (FD : File_Descriptor; Contents : out String_Access; Success : out Boolean); - -- Reads file associated with FS into the newly allocated - -- string Contents. - -- [VMS] Success is true iff the number of bytes read is less than or - -- equal to the file size. - -- [Other] Success is true iff the number of bytes read is equal to - -- the file size. + -- Reads file associated with FS into the newly allocated string Contents. + -- Success is true iff the number of bytes read is equal to the file size. function Report_Duplicate_Units return Boolean; -- Output messages about duplicate units in the input files in Unit.Table @@ -297,17 +292,17 @@ procedure Gnatchop is -- Write all units that result from chopping the Input file procedure Write_Config_File (Input : File_Num; U : Unit_Num); - -- Call to write configuration pragmas (append them to gnat.adc) - -- Input is the file number for the chop file and U identifies the - -- unit entry for the configuration pragmas. + -- Call to write configuration pragmas (append them to gnat.adc). Input is + -- the file number for the chop file and U identifies the unit entry for + -- the configuration pragmas. function Get_Config_Pragmas (Input : File_Num; U : Unit_Num) return String_Access; - -- Call to read configuration pragmas from given unit entry, and - -- return a buffer containing the pragmas to be appended to - -- following units. Input is the file number for the chop file and - -- U identifies the unit entry for the configuration pragmas. + -- Call to read configuration pragmas from given unit entry, and return a + -- buffer containing the pragmas to be appended to following units. Input + -- is the file number for the chop file and U identifies the unit entry for + -- the configuration pragmas. procedure Write_Source_Reference_Pragma (Info : Unit_Info; @@ -387,15 +382,8 @@ procedure Gnatchop is begin if Is_Writable_File (Info.File_Name.all) then - if Hostparm.OpenVMS then - Error_Msg - (Info.File_Name.all - & " already exists, use /OVERWRITE to overwrite"); - else - Error_Msg (Info.File_Name.all - & " already exists, use -w to overwrite"); - end if; - + Error_Msg (Info.File_Name.all + & " already exists, use -w to overwrite"); Exists := True; end if; end; @@ -1018,15 +1006,7 @@ procedure Gnatchop is Free (Buffer); end if; - -- Things aren't simple on VMS due to the plethora of file types and - -- organizations. It seems clear that there shouldn't be more bytes - -- read than are contained in the file though. - - if Hostparm.OpenVMS then - Success := Read_Ptr <= Length + 1; - else - Success := Read_Ptr = Length + 1; - end if; + Success := Read_Ptr = Length + 1; end Read_File; ---------------------------- @@ -1083,12 +1063,7 @@ procedure Gnatchop is end loop; if Duplicates and not Overwrite_Files then - if Hostparm.OpenVMS then - Put_Line - ("use /OVERWRITE to overwrite files and keep last version"); - else - Put_Line ("use -w to overwrite files and keep last version"); - end if; + Put_Line ("use -w to overwrite files and keep last version"); end if; return Duplicates; @@ -1136,23 +1111,13 @@ procedure Gnatchop is if Param.all /= "" then for J in Param'Range loop if Param (J) not in '0' .. '9' then - if Hostparm.OpenVMS then - Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn" & - " requires numeric parameter"); - else - Error_Msg ("-k# requires numeric parameter"); - end if; - + Error_Msg ("-k# requires numeric parameter"); return False; end if; end loop; else - if Hostparm.OpenVMS then - Param := new String'("39"); - else - Param := new String'("8"); - end if; + Param := new String'("8"); end if; Gnat_Args := @@ -1273,13 +1238,7 @@ procedure Gnatchop is return False; when Invalid_Parameter => - if Hostparm.OpenVMS then - Error_Msg ("/FILE_NAME_MAX_LENGTH=nnn qualifier" & - " requires numeric parameter"); - else - Error_Msg ("-k switch requires numeric parameter"); - end if; - + Error_Msg ("-k switch requires numeric parameter"); return False; end Scan_Arguments; @@ -1770,33 +1729,30 @@ procedure Gnatchop is begin -- Add the directory where gnatchop is invoked in front of the path, if - -- gnatchop is invoked with directory information. Only do this if the - -- platform is not VMS, where the notion of path does not really exist. + -- gnatchop is invoked with directory information. - if not Hostparm.OpenVMS then - declare - Command : constant String := Command_Name; + declare + Command : constant String := Command_Name; - begin - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir - & Path_Separator - & Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + PATH : constant String := + Absolute_Dir + & Path_Separator + & Getenv ("PATH").all; + begin + Setenv ("PATH", PATH); + end; - exit; - end if; - end loop; - end; - end if; + exit; + end if; + end loop; + end; -- Process command line options and initialize global variables diff --git a/main/gcc/ada/gnatcmd.adb b/main/gcc/ada/gnatcmd.adb index 7eb39cefdd4..77cf6dc47ae 100644 --- a/main/gcc/ada/gnatcmd.adb +++ b/main/gcc/ada/gnatcmd.adb @@ -26,7 +26,7 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Csets; -with Hostparm; use Hostparm; +with Gnatvsn; with Makeutl; use Makeutl; with MLib.Tgt; use MLib.Tgt; with MLib.Utl; @@ -47,11 +47,9 @@ with Snames; use Snames; with Stringt; with Switch; use Switch; with Table; -with Targparm; +with Targparm; use Targparm; with Tempdir; with Types; use Types; -with VMS_Conv; use VMS_Conv; -with VMS_Cmds; use VMS_Cmds; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; @@ -60,14 +58,57 @@ with Ada.Text_IO; use Ada.Text_IO; with GNAT.OS_Lib; use GNAT.OS_Lib; procedure GNATCmd is + Normal_Exit : exception; + -- Raise this exception for normal program termination + + Error_Exit : exception; + -- Raise this exception if error detected + + type Command_Type is + (Bind, + Chop, + Clean, + Compile, + Check, + Sync, + Elim, + Find, + Krunch, + Link, + List, + Make, + Metric, + Name, + Preprocess, + Pretty, + Stack, + Stub, + Test, + Xref, + Undefined); + + subtype Real_Command_Type is Command_Type range Bind .. Xref; + -- All real command types (excludes only Undefined). + + type Alternate_Command is (Comp, Ls, Kr, Pp, Prep); + -- Alternate command label + + Corresponding_To : constant array (Alternate_Command) of Command_Type := + (Comp => Compile, + Ls => List, + Kr => Krunch, + Prep => Preprocess, + Pp => Pretty); + -- Mapping of alternate commands to commands + Project_Node_Tree : Project_Node_Tree_Ref; Project_File : String_Access; Project : Prj.Project_Id; Current_Verbosity : Prj.Verbosity := Prj.Default; Tool_Package_Name : Name_Id := No_Name; - B_Start : String_Ptr := new String'("b~"); - -- Prefix of binder generated file, changed to b__ for VMS + B_Start : constant String := "b~"; + -- Prefix of binder generated file Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); @@ -120,6 +161,14 @@ procedure GNATCmd is Table_Increment => 100, Table_Name => "Make.Library_Path"); + package Last_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.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. @@ -192,8 +241,7 @@ procedure GNATCmd is -- The index of the command in the arguments of the GNAT driver My_Exit_Status : Exit_Status := Success; - -- The exit status of the spawned tool. Used to set the correct VMS - -- exit status. + -- The exit status of the spawned tool Current_Work_Dir : constant String := Get_Current_Dir; -- The path of the working directory @@ -203,8 +251,120 @@ procedure GNATCmd is -- indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric) -- should be invoked for all sources of all projects. - Max_OpenVMS_Logical_Length : constant Integer := 255; - -- The maximum length of OpenVMS logicals + type Command_Entry is record + Cname : String_Access; + -- Command name for GNAT xxx command + + Unixcmd : String_Access; + -- Corresponding Unix command + + Unixsws : Argument_List_Access; + -- List of switches to be used with the Unix command + end record; + + Command_List : constant array (Real_Command_Type) of Command_Entry := + (Bind => + (Cname => new String'("BIND"), + Unixcmd => new String'("gnatbind"), + Unixsws => null), + + Chop => + (Cname => new String'("CHOP"), + Unixcmd => new String'("gnatchop"), + Unixsws => null), + + Clean => + (Cname => new String'("CLEAN"), + Unixcmd => new String'("gnatclean"), + Unixsws => null), + + Compile => + (Cname => new String'("COMPILE"), + Unixcmd => new String'("gnatmake"), + Unixsws => new Argument_List'(1 => new String'("-f"), + 2 => new String'("-u"), + 3 => new String'("-c"))), + + Check => + (Cname => new String'("CHECK"), + Unixcmd => new String'("gnatcheck"), + Unixsws => null), + + Sync => + (Cname => new String'("SYNC"), + Unixcmd => new String'("gnatsync"), + Unixsws => null), + + Elim => + (Cname => new String'("ELIM"), + Unixcmd => new String'("gnatelim"), + Unixsws => null), + + Find => + (Cname => new String'("FIND"), + Unixcmd => new String'("gnatfind"), + Unixsws => null), + + Krunch => + (Cname => new String'("KRUNCH"), + Unixcmd => new String'("gnatkr"), + Unixsws => null), + + Link => + (Cname => new String'("LINK"), + Unixcmd => new String'("gnatlink"), + Unixsws => null), + + List => + (Cname => new String'("LIST"), + Unixcmd => new String'("gnatls"), + Unixsws => null), + + Make => + (Cname => new String'("MAKE"), + Unixcmd => new String'("gnatmake"), + Unixsws => null), + + Metric => + (Cname => new String'("METRIC"), + Unixcmd => new String'("gnatmetric"), + Unixsws => null), + + Name => + (Cname => new String'("NAME"), + Unixcmd => new String'("gnatname"), + Unixsws => null), + + Preprocess => + (Cname => new String'("PREPROCESS"), + Unixcmd => new String'("gnatprep"), + Unixsws => null), + + Pretty => + (Cname => new String'("PRETTY"), + Unixcmd => new String'("gnatpp"), + Unixsws => null), + + Stack => + (Cname => new String'("STACK"), + Unixcmd => new String'("gnatstack"), + Unixsws => null), + + Stub => + (Cname => new String'("STUB"), + Unixcmd => new String'("gnatstub"), + Unixsws => null), + + Test => + (Cname => new String'("TEST"), + Unixcmd => new String'("gnattest"), + Unixsws => null), + + Xref => + (Cname => new String'("XREF"), + Unixcmd => new String'("gnatxref"), + Unixsws => null) + ); ----------------------- -- Local Subprograms -- @@ -263,8 +423,11 @@ procedure GNATCmd is -- (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric -- (GNAT METRIC). - procedure Non_VMS_Usage; - -- Display usage for platforms other than VMS + procedure Output_Version; + -- Output the version of this program + + procedure Usage; + -- Display usage procedure Process_Link; -- Process GNAT LINK, when there is a project file specified @@ -452,7 +615,7 @@ procedure GNATCmd is Add_To_Response_File (Get_Name_String (Proj.Project.Object_Directory.Name) & - B_Start.all & + B_Start & MLib.Fil.Ext_To (Get_Name_String (Project_Tree.Shared.String_Elements.Table @@ -465,7 +628,6 @@ procedure GNATCmd is -- such files. if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) - and then B_Start.all /= "b__" then Add_To_Response_File (Get_Name_String @@ -491,7 +653,7 @@ procedure GNATCmd is Add_To_Response_File (Get_Name_String (Proj.Project.Object_Directory.Name) & - B_Start.all & + B_Start & Get_Name_String (Proj.Project.Library_Name) & ".ci"); @@ -501,7 +663,6 @@ procedure GNATCmd is -- such files. if not Is_Regular_File (Name_Buffer (1 .. Name_Len)) - and then B_Start.all /= "b__" then Add_To_Response_File (Get_Name_String @@ -861,8 +1022,7 @@ procedure GNATCmd is Prj.Env.Create_Temp_File (Project_Tree.Shared, FD, Name, "files"); - -- And close it, because on VMS Spawn with a file descriptor created - -- with Create_Temp_File does not redirect output. + -- And close it Close (FD); @@ -989,11 +1149,29 @@ procedure GNATCmd is return Result; end Mapping_File; - ------------------- - -- Non_VMS_Usage -- - ------------------- + -------------------- + -- Output_Version -- + -------------------- + + procedure Output_Version is + begin + if AAMP_On_Target then + Put ("GNAAMP "); + else + Put ("GNAT "); + end if; - procedure Non_VMS_Usage is + Put_Line (Gnatvsn.Gnat_Version_String); + Put_Line ("Copyright 1996-" & + Gnatvsn.Current_Year & + ", Free Software Foundation, Inc."); + end Output_Version; + + ----------- + -- Usage -- + ----------- + + procedure Usage is begin Output_Version; New_Line; @@ -1002,9 +1180,9 @@ procedure GNATCmd is for C in Command_List'Range loop - -- No usage for VMS only command or for Sync + -- No usage for Sync - if not Command_List (C).VMS_Only and then C /= Sync then + if C /= Sync then if Targparm.AAMP_On_Target then Put ("gnaampcmd "); else @@ -1041,7 +1219,7 @@ procedure GNATCmd is Put_Line ("All commands except chop, krunch and preprocess " & "accept project file switches -vPx, -Pprj and -Xnam=val"); New_Line; - end Non_VMS_Usage; + end Usage; ------------------ -- Process_Link -- @@ -1374,7 +1552,7 @@ procedure GNATCmd is end Set_Library_For; procedure Check_Version_And_Help is - new Check_Version_And_Help_G (Non_VMS_Usage); + new Check_Version_And_Help_G (Usage); -- Start of processing for GNATCmd @@ -1406,17 +1584,12 @@ begin Rules_Switches.Init; Rules_Switches.Set_Last (0); - VMS_Conv.Initialize; - - -- Add the default search directories, to be able to find system.ads in the - -- subsequent call to Targparm.Get_Target_Parameters. - - Add_Default_Search_Dirs; + -- 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. - -- Get target parameters so that AAMP_On_Target will be set, for testing in - -- Osint.Program_Name to handle the mapping of GNAAMP tool names. - - Targparm.Get_Target_Parameters; + 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. @@ -1429,179 +1602,147 @@ begin Add_Str_To_Name_Buffer (Argument (J)); end loop; - -- On OpenVMS, setenv creates a logical whose length is limited to - -- 255 bytes. - - if OpenVMS and then Name_Len > Max_OpenVMS_Logical_Length then - Name_Buffer (Max_OpenVMS_Logical_Length - 2 - .. Max_OpenVMS_Logical_Length) := "..."; - Name_Len := Max_OpenVMS_Logical_Length; - end if; - Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len)); -- Add the directory where the GNAT driver is invoked in front of the path, - -- if the GNAT driver is invoked with directory information. Do not do this - -- for VMS, where the notion of path does not really exist. + -- if the GNAT driver is invoked with directory information. - if not OpenVMS then - declare - Command : constant String := Command_Name; - - begin - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - - PATH : constant String := - Absolute_Dir & Path_Separator & Getenv ("PATH").all; + declare + Command : constant String := Command_Name; - begin - Setenv ("PATH", PATH); - end; + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); - exit; - end if; - end loop; - end; - end if; + PATH : constant String := + Absolute_Dir & Path_Separator & Getenv ("PATH").all; - -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, - -- filenames and pathnames to Unix style. + begin + Setenv ("PATH", PATH); + end; - if Hostparm.OpenVMS - or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" - then - VMS_Conversion (The_Command); + exit; + end if; + end loop; + end; - B_Start := new String'("b__"); + -- Scan the command line - -- If not on VMS, scan the command line directly + -- First, scan to detect --version and/or --help - else - -- First, scan to detect --version and/or --help + Check_Version_And_Help ("GNAT", "1996"); - Check_Version_And_Help ("GNAT", "1996"); + begin + loop + if Command_Arg <= Argument_Count + and then Argument (Command_Arg) = "-v" + then + Verbose_Mode := True; + Command_Arg := Command_Arg + 1; - begin - loop - if Command_Arg <= Argument_Count - and then Argument (Command_Arg) = "-v" - then - Verbose_Mode := True; - Command_Arg := Command_Arg + 1; + elsif Command_Arg <= Argument_Count + and then Argument (Command_Arg) = "-dn" + then + Keep_Temporary_Files := True; + Command_Arg := Command_Arg + 1; - elsif Command_Arg <= Argument_Count - and then Argument (Command_Arg) = "-dn" - then - Keep_Temporary_Files := True; - Command_Arg := Command_Arg + 1; + else + exit; + end if; + end loop; - else - exit; - end if; - end loop; + -- If there is no command, just output the usage - -- If there is no command, just output the usage + if Command_Arg > Argument_Count then + Usage; + return; + end if; - if Command_Arg > Argument_Count then - Non_VMS_Usage; - return; - end if; + The_Command := Real_Command_Type'Value (Argument (Command_Arg)); - The_Command := Real_Command_Type'Value (Argument (Command_Arg)); + exception + when Constraint_Error => - if Command_List (The_Command).VMS_Only then - Non_VMS_Usage; - Fail - ("command """ - & Command_List (The_Command).Cname.all - & """ can only be used on VMS"); - end if; + -- Check if it is an alternate command - exception - when Constraint_Error => + declare + Alternate : Alternate_Command; - -- Check if it is an alternate command + begin + Alternate := Alternate_Command'Value + (Argument (Command_Arg)); + The_Command := Corresponding_To (Alternate); - declare - Alternate : Alternate_Command; + exception + when Constraint_Error => + Usage; + Fail ("unknown command: " & Argument (Command_Arg)); + end; + end; - begin - Alternate := Alternate_Command'Value - (Argument (Command_Arg)); - The_Command := Corresponding_To (Alternate); - - exception - when Constraint_Error => - Non_VMS_Usage; - Fail ("unknown command: " & Argument (Command_Arg)); - end; - end; + -- Get the arguments from the command line and from the eventual + -- argument file(s) specified on the command line. - -- Get the arguments from the command line and from the eventual - -- argument file(s) specified on the command line. + for Arg in Command_Arg + 1 .. Argument_Count loop + declare + The_Arg : constant String := Argument (Arg); - for Arg in Command_Arg + 1 .. Argument_Count loop - declare - The_Arg : constant String := Argument (Arg); + begin + -- Check if an argument file is specified - begin - -- Check if an argument file is specified + if The_Arg (The_Arg'First) = '@' then + declare + Arg_File : Ada.Text_IO.File_Type; + Line : String (1 .. 256); + Last : Natural; - if The_Arg (The_Arg'First) = '@' then - declare - Arg_File : Ada.Text_IO.File_Type; - Line : String (1 .. 256); - Last : Natural; + begin + -- Open the file and fail if the file cannot be found begin - -- Open the file and fail if the file cannot be found - - begin - Open - (Arg_File, In_File, - The_Arg (The_Arg'First + 1 .. The_Arg'Last)); - - exception - when others => - Put (Standard_Error, "Cannot open argument file """); - Put (Standard_Error, - The_Arg (The_Arg'First + 1 .. The_Arg'Last)); - Put_Line (Standard_Error, """"); - raise Error_Exit; - end; + Open + (Arg_File, In_File, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + + exception + when others => + Put (Standard_Error, "Cannot open argument file """); + Put (Standard_Error, + The_Arg (The_Arg'First + 1 .. The_Arg'Last)); + Put_Line (Standard_Error, """"); + raise Error_Exit; + end; - -- Read line by line and put the content of each non- - -- empty line in the Last_Switches table. + -- Read line by line and put the content of each non- + -- empty line in the Last_Switches table. - while not End_Of_File (Arg_File) loop - Get_Line (Arg_File, Line, Last); + while not End_Of_File (Arg_File) loop + Get_Line (Arg_File, Line, Last); - if Last /= 0 then - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'(Line (1 .. Last)); - end if; - end loop; + if Last /= 0 then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(Line (1 .. Last)); + end if; + end loop; - Close (Arg_File); - end; + Close (Arg_File); + end; - else - -- It is not an argument file; just put the argument in - -- the Last_Switches table. + else + -- It is not an argument file; just put the argument in + -- the Last_Switches table. - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := - new String'(The_Arg); - end if; - end; - end loop; - end if; + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := + new String'(The_Arg); + end if; + end; + end loop; declare Program : String_Access; @@ -2618,20 +2759,6 @@ begin if ASIS_Main /= null then Get_Closure; - -- On VMS, set up the env var again for source dirs file. This is - -- because the call to gnatmake has set this env var to another - -- file that has now been deleted. - - if Hostparm.OpenVMS then - - -- First make sure that the recorded file names are empty - - Prj.Env.Initialize (Project_Tree); - - Prj.Env.Set_Ada_Paths - (Project, Project_Tree, Including_Libraries => False); - end if; - -- For gnat check, gnat sync, gnat pretty, gnat metric, gnat list, -- and gnat stack, if no file has been put on the command line, call -- tool with all the sources of the main project. @@ -2678,22 +2805,6 @@ begin The_Args (Arg_Num) := Rules_Switches.Table (J); end loop; - -- If Display_Command is on, only display the generated command - - if Display_Command then - Put (Standard_Error, "generated command -->"); - Put (Standard_Error, Exec_Path.all); - - for Arg in The_Args'Range loop - Put (Standard_Error, " "); - Put (Standard_Error, The_Args (Arg).all); - end loop; - - Put (Standard_Error, "<--"); - New_Line (Standard_Error); - raise Normal_Exit; - end if; - if Verbose_Mode then Output.Write_Str (Exec_Path.all); @@ -2726,14 +2837,5 @@ exception Delete_Temp_Config_Files; end if; - -- Since GNATCmd is normally called from DCL (the VMS shell), it must - -- return an understandable VMS exit status. However the exit status - -- returned *to* GNATCmd is a Posix style code, so we test it and return - -- just a simple success or failure on VMS. - - if Hostparm.OpenVMS and then My_Exit_Status /= Success then - Set_Exit_Status (Failure); - else - Set_Exit_Status (My_Exit_Status); - end if; + Set_Exit_Status (My_Exit_Status); end GNATCmd; diff --git a/main/gcc/ada/gnatcmd.ads b/main/gcc/ada/gnatcmd.ads index 6c2c8c7f50f..13a709947a5 100644 --- a/main/gcc/ada/gnatcmd.ads +++ b/main/gcc/ada/gnatcmd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,35 +24,19 @@ ------------------------------------------------------------------------------ -- This program provides a simple command interface for using GNAT and its --- associated utilities. The format of switches accepted is intended to --- be more familiar in style for VMS and DOS users than the standard Unix --- style switches that are accepted directly. +-- associated utilities. -- The program is typically called GNAT when it is installed and -- the two possible styles of use are: -- To call gcc: --- GNAT filename switches +-- GNAT compile filename switches -- To call the tool gnatxxx -- GNAT xxx filename switches --- where xxx is the command name (e.g. MAKE for gnatmake). This command name --- can be abbreviated by giving a prefix (e.g. GNAT MAK) as long as it --- remains unique. - --- In both cases, filename is in the format appropriate to the operating --- system in use. The individual commands give more details. In some cases --- a unit name may be given in place of a file name. - --- The switches start with a slash. Switch names can also be abbreviated --- where no ambiguity arises. The switches associated with each command --- are specified by the tables that can be found in the body. - --- Although by convention we use upper case for command names and switches --- in the documentation, all command and switch names are case insensitive --- and may be given in upper case or lower case or a mixture. +-- where xxx is the command name (e.g. MAKE for gnatmake). procedure GNATCmd; diff --git a/main/gcc/ada/gnatlink.adb b/main/gcc/ada/gnatlink.adb index ce8f3d18b65..6c93c0ba62e 100644 --- a/main/gcc/ada/gnatlink.adb +++ b/main/gcc/ada/gnatlink.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +28,6 @@ with ALI; use ALI; with Csets; with Gnatvsn; use Gnatvsn; -with Hostparm; with Indepsw; use Indepsw; with Namet; use Namet; with Opt; @@ -228,12 +227,6 @@ procedure Gnatlink is procedure Process_Binder_File (Name : String); -- Reads the binder file and extracts linker arguments - function To_Lower (A : Character) return Character; - -- Fold a character to lower case; - - procedure To_Lower (A : in out String); - -- Fold a string to lower case; - procedure Usage; -- Display usage @@ -637,8 +630,7 @@ procedure Gnatlink is Linker_Objects.Table (Linker_Objects.Last) := new String'(Arg); - -- If host object file, record object file e.g. accept foo.o - -- as well as foo.obj on VMS target. + -- If host object file, record object file elsif Arg'Length > Get_Object_Suffix.all'Length and then Arg @@ -737,18 +729,17 @@ procedure Gnatlink is -- Save state of -shared option Xlinker_Was_Previous : Boolean := False; - -- Indicate that "-Xlinker" was the option preceding the current - -- option. If True, then the current option is never suppressed. + -- Indicate that "-Xlinker" was the option preceding the current option. + -- If True, then the current option is never suppressed. -- Rollback data - -- These data items are used to store current binder file context. - -- The context is composed of the file descriptor position and the - -- current line together with the slice indexes (first and last - -- position) for this line. The rollback data are used by the - -- Store_File_Context and Rollback_File_Context routines below. - -- The file context mechanism interact only with the Get_Next_Line - -- call. For example: + -- These data items are used to store current binder file context. The + -- context is composed of the file descriptor position and the current + -- line together with the slice indexes (first and last position) for + -- this line. The rollback data are used by the Store_File_Context and + -- Rollback_File_Context routines below. The file context mechanism + -- interact only with the Get_Next_Line call. For example: -- Store_File_Context; -- Get_Next_Line; @@ -779,7 +770,7 @@ procedure Gnatlink is pragma Import (C, Object_Library_Ext_Ptr, "__gnat_object_library_extension"); -- Pointer to string specifying the default extension for - -- object libraries, e.g. Unix uses ".a", VMS uses ".olb". + -- object libraries, e.g. Unix uses ".a". Separate_Run_Path_Options : Boolean; for Separate_Run_Path_Options'Size use Character'Size; @@ -794,10 +785,6 @@ procedure Gnatlink is function Index (S, Pattern : String) return Natural; -- Return the last occurrence of Pattern in S, or 0 if none - function Is_Option_Present (Opt : String) return Boolean; - -- Return true if the option Opt is already present in - -- Linker_Options table. - procedure Store_File_Context; -- Store current file context, Fd position and current line data. -- The file context is stored into the rollback data above (RB_*). @@ -856,23 +843,6 @@ procedure Gnatlink is return 0; end Index; - ----------------------- - -- Is_Option_Present -- - ----------------------- - - function Is_Option_Present (Opt : String) return Boolean is - begin - for I in 1 .. Linker_Options.Last loop - - if Linker_Options.Table (I).all = Opt then - return True; - end if; - - end loop; - - return False; - end Is_Option_Present; - --------------------------- -- Rollback_File_Context -- --------------------------- @@ -1098,13 +1068,7 @@ procedure Gnatlink is -- Add binder options only if not already set on the command line. -- This rule is a way to control the linker options order. - -- The following test needs comments, why is it VMS specific. - -- The above comment looks out of date ??? - - elsif not - (OpenVMS_On_Target - and then Is_Option_Present (Next_Line (Nfirst .. Nlast))) - then + else if Nlast > Nfirst + 2 and then Next_Line (Nfirst .. Nfirst + 1) = "-L" then @@ -1126,8 +1090,7 @@ procedure Gnatlink is Linker_Options.Table (Linker_Options.Last) := new String'(Next_Line (Nfirst .. Nlast)); - elsif Next_Line (Nfirst .. Nlast) = "-ldecgnat" - or else Next_Line (Nfirst .. Nlast) = "-lgnarl" + elsif Next_Line (Nfirst .. Nlast) = "-lgnarl" or else Next_Line (Nfirst .. Nlast) = "-lgnat" or else Next_Line @@ -1417,31 +1380,6 @@ procedure Gnatlink is Status := fclose (Fd); end Process_Binder_File; - -------------- - -- To_Lower -- - -------------- - - function To_Lower (A : Character) return Character is - A_Val : constant Natural := Character'Pos (A); - - begin - if A in 'A' .. 'Z' - or else A_Val in 16#C0# .. 16#D6# - or else A_Val in 16#D8# .. 16#DE# - then - return Character'Val (A_Val + 16#20#); - else - return A; - end if; - end To_Lower; - - procedure To_Lower (A : in out String) is - begin - for J in A'Range loop - A (J) := To_Lower (A (J)); - end loop; - end To_Lower; - ----------- -- Usage -- ----------- @@ -1507,45 +1445,33 @@ procedure Gnatlink is begin -- Add the directory where gnatlink is invoked in front of the path, if - -- gnatlink is invoked with directory information. Only do this if the - -- platform is not VMS, where the notion of path does not really exist. + -- gnatlink is invoked with directory information. - if not Hostparm.OpenVMS then - declare - Command : constant String := Command_Name; - - begin - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); + declare + Command : constant String := Command_Name; + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; + PATH : constant String := + Absolute_Dir & + Path_Separator & + Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; + begin + Setenv ("PATH", PATH); + end; - exit; - end if; - end loop; - end; - end if; + exit; + end if; + end loop; + end; Base_Command_Name := new String'(Base_Name (Command_Name)); - - -- Fold to lower case "GNATLINK" on VMS to be consistent with output - -- from other GNAT utilities. - - if Hostparm.OpenVMS then - To_Lower (Base_Command_Name.all); - end if; - Process_Args; if Argument_Count = 0 @@ -1676,13 +1602,11 @@ begin Osint.Add_Default_Search_Dirs; Targparm.Get_Target_Parameters; - if VM_Target /= No_VM then - case VM_Target is - when JVM_Target => Gcc := new String'("jvm-gnatcompile"); - when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); - when No_VM => raise Program_Error; - end case; - end if; + case VM_Target is + when JVM_Target => Gcc := new String'("jvm-gnatcompile"); + when CLI_Target => Gcc := new String'("dotnet-gnatcompile"); + when No_VM => null; + end case; -- Compile the bind file with the following switches: @@ -1734,17 +1658,6 @@ begin if Linker_Path = null then Exit_With_Error ("Couldn't locate dotnet-ld"); end if; - - elsif RTX_RTSS_Kernel_Module_On_Target then - - -- Use Microsoft linker for RTSS modules - - Linker_Path := System.OS_Lib.Locate_Exec_On_Path ("link"); - - if Linker_Path = null then - Exit_With_Error ("Couldn't locate link"); - end if; - else Linker_Path := Gcc_Path; end if; @@ -1760,19 +1673,12 @@ begin & Get_Target_Debuggable_Suffix.all); end if; - if RTX_RTSS_Kernel_Module_On_Target then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("/OUT:" & Output_File_Name.all); - - else - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := new String'("-o"); + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := new String'("-o"); - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'(Output_File_Name.all); - end if; + Linker_Options.Increment_Last; + Linker_Options.Table (Linker_Options.Last) := + new String'(Output_File_Name.all); Check_Existing_Executable (Output_File_Name.all); @@ -1828,11 +1734,10 @@ begin end loop; -- For now we detect windows by an output executable name ending with - -- the suffix .exe (excluding VMS which might use that same name). + -- the suffix .exe. if FN'Length > 5 and then FN (FN'Last - 3 .. FN'Last) = ".exe" - and then not OpenVMS_On_Target then Check_File_Name ("install"); Check_File_Name ("setup"); @@ -1880,11 +1785,7 @@ begin begin -- Set prefix - if OpenVMS_On_Target then - Bind_File_Prefix := new String'("b__"); - else - Bind_File_Prefix := new String'("b~"); - end if; + Bind_File_Prefix := new String'("b~"); -- If the length of the binder file becomes too long due to -- the addition of the "b?" prefix, then truncate it. @@ -1979,359 +1880,209 @@ begin -- the actual link at run time. We might consider packing all class files -- in a .zip file during this step. - if VM_Target /= JVM_Target then - Link_Step : declare - Num_Args : Natural := - (Linker_Options.Last - Linker_Options.First + 1) + - (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) + - (Linker_Objects.Last - Linker_Objects.First + 1); - Stack_Op : Boolean := False; - IDENT_Op : Boolean := False; + Link_Step : declare + Num_Args : Natural := + (Linker_Options.Last - Linker_Options.First + 1) + + (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) + + (Linker_Objects.Last - Linker_Objects.First + 1); + Stack_Op : Boolean := False; - begin - if AAMP_On_Target then + begin + if AAMP_On_Target then - -- Remove extraneous flags not relevant for AAMP + -- 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; + 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; - elsif RTX_RTSS_Kernel_Module_On_Target then + -- 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 + -- ("-Xlinker" then "--stack=R,C") when set on the command line. We + -- also check for the "-Wl,--stack=R" style option. - -- Remove irrelevant flags for Microsoft linker, adapt some others + -- We must remove the second stack setting option instance because + -- the one on the command line will always be the first one. And any + -- subsequent stack setting option will overwrite the previous one. + -- This is done especially for GNAT/NT where we set the stack size + -- for tasking programs by a pragma in the NT specific tasking + -- package System.Task_Primitives.Operations. - for J in reverse Linker_Options.First .. Linker_Options.Last loop + -- Note: This is not a FOR loop that runs from Linker_Options.First + -- to Linker_Options.Last, since operations within the loop can + -- modify the length of the table. - -- Remove flags that are not accepted + Clean_Link_Option_Set : declare + J : Natural; + Shared_Libgcc_Seen : Boolean := False; - if Linker_Options.Table (J)'Length = 0 - or else Linker_Options.Table (J) (1 .. 2) = "-l" - 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 .. 8) = "-Xlinker" - or else Linker_Options.Table (J) (1 .. 9) = "-mthreads" - then - Linker_Options.Table (J .. Linker_Options.Last - 1) := - Linker_Options.Table (J + 1 .. Linker_Options.Last); + begin + J := Linker_Options.First; + while J <= Linker_Options.Last loop + if Linker_Options.Table (J).all = "-Xlinker" + and then J < Linker_Options.Last + and then Linker_Options.Table (J + 1)'Length > 8 + and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack=" + then + if Stack_Op then + Linker_Options.Table (J .. Linker_Options.Last - 2) := + Linker_Options.Table (J + 2 .. Linker_Options.Last); Linker_Options.Decrement_Last; - Num_Args := Num_Args - 1; - - -- Replace "-L" by its counterpart "/LIBPATH:" and UNIX "/" by - -- Windows "\". - - elsif Linker_Options.Table (J) (1 .. 2) = "-L" then - declare - Libpath_Option : constant String_Access := new String' - ("/LIBPATH:" & - Linker_Options.Table - (J) (3 .. Linker_Options.Table (J).all'Last)); - begin - for Index in 10 .. Libpath_Option'Last loop - if Libpath_Option (Index) = '/' then - Libpath_Option (Index) := '\'; - end if; - end loop; - - Linker_Options.Table (J) := Libpath_Option; - end; - - -- Replace "-g" by "/DEBUG" - - elsif Linker_Options.Table (J) (1 .. 2) = "-g" then - Linker_Options.Table (J) := new String'("/DEBUG"); + Linker_Options.Decrement_Last; + Num_Args := Num_Args - 2; - -- Replace "-o" by "/OUT:" + else + Stack_Op := True; + end if; + end if; - elsif Linker_Options.Table (J) (1 .. 2) = "-o" then - Linker_Options.Table (J + 1) := new String' - ("/OUT:" & Linker_Options.Table (J + 1).all); + -- Remove duplicate -shared-libgcc switch + if Linker_Options.Table (J).all = Shared_Libgcc_String then + if Shared_Libgcc_Seen 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; - -- Replace "--stack=" by "/STACK:" - - elsif Linker_Options.Table (J) (1 .. 8) = "--stack=" then - Linker_Options.Table (J) := new String' - ("/STACK:" & - Linker_Options.Table (J) - (9 .. Linker_Options.Table (J).all'Last)); - - -- Replace "-v" by its counterpart "/VERBOSE" - - elsif Linker_Options.Table (J) (1 .. 2) = "-v" then - Linker_Options.Table (J) := new String'("/VERBOSE"); - end if; - end loop; - - -- Add some required flags to create RTSS modules - - declare - Flags_For_Linker : constant array (1 .. 17) of String_Access := - (new String'("/NODEFAULTLIB"), - new String'("/INCREMENTAL:NO"), - new String'("/NOLOGO"), - new String'("/DRIVER"), - new String'("/ALIGN:0x20"), - new String'("/SUBSYSTEM:NATIVE"), - new String'("/ENTRY:_RtapiProcessEntryCRT@8"), - new String'("/RELEASE"), - new String'("startupCRT.obj"), - new String'("rtxlibcmt.lib"), - new String'("oldnames.lib"), - new String'("rtapi_rtss.lib"), - new String'("Rtx_Rtss.lib"), - new String'("libkernel32.a"), - new String'("libws2_32.a"), - new String'("libmswsock.a"), - new String'("libadvapi32.a")); - -- These flags need to be passed to Microsoft linker. They - -- come from the RTX documentation. - - Gcc_Lib_Path : constant String_Access := new String' - ("/LIBPATH:" & Include_Dir_Default_Prefix & "\..\"); - -- Place to look for gcc related libraries, such as libgcc - - begin - -- Replace UNIX "/" by Windows "\" in the path - - for Index in 10 .. Gcc_Lib_Path.all'Last loop - if Gcc_Lib_Path (Index) = '/' then - Gcc_Lib_Path (Index) := '\'; - end if; - end loop; - - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := Gcc_Lib_Path; - Num_Args := Num_Args + 1; - - for Index in Flags_For_Linker'Range loop - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - Flags_For_Linker (Index); - Num_Args := Num_Args + 1; - end loop; - end; - 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 - -- ("-Xlinker" then "--stack=R,C") when set on the command line. We - -- also check for the "-Wl,--stack=R" style option. - - -- We must remove the second stack setting option instance because - -- the one on the command line will always be the first one. And any - -- subsequent stack setting option will overwrite the previous one. - -- This is done especially for GNAT/NT where we set the stack size - -- for tasking programs by a pragma in the NT specific tasking - -- package System.Task_Primitives.Operations. - - -- Note: This is not a FOR loop that runs from Linker_Options.First - -- to Linker_Options.Last, since operations within the loop can - -- modify the length of the table. - - Clean_Link_Option_Set : declare - J : Natural; - Shared_Libgcc_Seen : Boolean := False; - - begin - J := Linker_Options.First; - while J <= Linker_Options.Last loop - if Linker_Options.Table (J).all = "-Xlinker" - and then J < Linker_Options.Last - and then Linker_Options.Table (J + 1)'Length > 8 - and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack=" - then - if Stack_Op then - Linker_Options.Table (J .. Linker_Options.Last - 2) := - Linker_Options.Table (J + 2 .. Linker_Options.Last); - Linker_Options.Decrement_Last; - Linker_Options.Decrement_Last; - Num_Args := Num_Args - 2; - - else - Stack_Op := True; - end if; - end if; - - -- Remove duplicate -shared-libgcc switch - - if Linker_Options.Table (J).all = Shared_Libgcc_String then - if Shared_Libgcc_Seen 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; - - else - Shared_Libgcc_Seen := True; - end if; - end if; - - -- Here we just check for a canonical form that matches the - -- pragma Linker_Options set in the NT runtime. - - if (Linker_Options.Table (J)'Length > 17 - and then Linker_Options.Table (J) (1 .. 17) = - "-Xlinker --stack=") - or else - (Linker_Options.Table (J)'Length > 12 - and then Linker_Options.Table (J) (1 .. 12) = - "-Wl,--stack=") - then - if Stack_Op 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; - - else - Stack_Op := True; - end if; + else + Shared_Libgcc_Seen := True; end if; + end if; - -- Remove duplicate IDENTIFICATION directives (VMS) + -- Here we just check for a canonical form that matches the + -- pragma Linker_Options set in the NT runtime. - if Linker_Options.Table (J)'Length > 29 - and then Linker_Options.Table (J) (1 .. 30) = - "--for-linker=--identification=" - then - if IDENT_Op 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; + if (Linker_Options.Table (J)'Length > 17 + and then Linker_Options.Table (J) (1 .. 17) = + "-Xlinker --stack=") + or else + (Linker_Options.Table (J)'Length > 12 + and then Linker_Options.Table (J) (1 .. 12) = + "-Wl,--stack=") + then + if Stack_Op 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; - else - IDENT_Op := True; - end if; + else + Stack_Op := True; end if; + end if; - J := J + 1; - end loop; - - if Linker_Path = Gcc_Path and then VM_Target = No_VM then - - -- For systems where the default is to link statically with - -- libgcc, if gcc is not called with -shared-libgcc, call it - -- with -static-libgcc, as there are some platforms where one - -- of these two switches is compulsory to link. - - if Shared_Libgcc_Default = 'T' - and then not Shared_Libgcc_Seen - then - Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; - Num_Args := Num_Args + 1; - end if; + J := J + 1; + end loop; - elsif RTX_RTSS_Kernel_Module_On_Target then + if Linker_Path = Gcc_Path and then VM_Target = No_VM then - -- Force the use of the static libgcc for RTSS modules + -- For systems where the default is to link statically with + -- libgcc, if gcc is not called with -shared-libgcc, call it + -- with -static-libgcc, as there are some platforms where one + -- of these two switches is compulsory to link. + if Shared_Libgcc_Default = 'T' + and then not Shared_Libgcc_Seen + then Linker_Options.Increment_Last; - Linker_Options.Table (Linker_Options.Last) := - new String'("libgcc.a"); + Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; Num_Args := Num_Args + 1; end if; + end if; + end Clean_Link_Option_Set; - end Clean_Link_Option_Set; + -- Prepare arguments for call to linker - -- Prepare arguments for call to linker + Call_Linker : declare + Success : Boolean; + Args : Argument_List (1 .. Num_Args + 1); + Index : Integer := Args'First; - Call_Linker : declare - Success : Boolean; - Args : Argument_List (1 .. Num_Args + 1); - Index : Integer := Args'First; + begin + Args (Index) := Binder_Obj_File; - begin - Args (Index) := Binder_Obj_File; + -- Add the object files and any -largs libraries + + for J in Linker_Objects.First .. Linker_Objects.Last loop + Index := Index + 1; + Args (Index) := Linker_Objects.Table (J); + end loop; - -- Add the object files and any -largs libraries + -- Add the linker options from the binder file - for J in Linker_Objects.First .. Linker_Objects.Last loop - Index := Index + 1; - Args (Index) := Linker_Objects.Table (J); - end loop; + for J in Linker_Options.First .. Linker_Options.Last loop + Index := Index + 1; + Args (Index) := Linker_Options.Table (J); + end loop; - -- Add the linker options from the binder file + -- Finally add the libraries from the --GCC= switch - for J in Linker_Options.First .. Linker_Options.Last loop - Index := Index + 1; - Args (Index) := Linker_Options.Table (J); - end loop; + for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop + Index := Index + 1; + Args (Index) := Gcc_Linker_Options.Table (J); + end loop; - -- Finally add the libraries from the --GCC= switch + if Verbose_Mode then + Write_Str (Linker_Path.all); - for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop - Index := Index + 1; - Args (Index) := Gcc_Linker_Options.Table (J); + for J in Args'Range loop + Write_Str (" "); + Write_Str (Args (J).all); end loop; - if Verbose_Mode then - Write_Str (Linker_Path.all); + Write_Eol; - for J in Args'Range loop - Write_Str (" "); - Write_Str (Args (J).all); - end loop; + -- If we are on very verbose mode (-v -v) and a response file + -- is used we display its content. + if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then + Write_Eol; + Write_Str ("Response file (" & + Tname (Tname'First .. Tname'Last - 1) & + ") content : "); Write_Eol; - -- If we are on very verbose mode (-v -v) and a response file - -- is used we display its content. - - if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then - Write_Eol; - Write_Str ("Response file (" & - Tname (Tname'First .. Tname'Last - 1) & - ") content : "); + for J in + Response_File_Objects.First .. Response_File_Objects.Last + loop + Write_Str (Response_File_Objects.Table (J).all); Write_Eol; + end loop; - for J in - Response_File_Objects.First .. Response_File_Objects.Last - loop - Write_Str (Response_File_Objects.Table (J).all); - Write_Eol; - end loop; - - Write_Eol; - end if; + Write_Eol; end if; + end if; - System.OS_Lib.Spawn (Linker_Path.all, Args, Success); - - if Success then + System.OS_Lib.Spawn (Linker_Path.all, Args, Success); - -- Delete the temporary file used in conjunction with linking - -- if one was created. See Process_Bind_File for details. + if Success then - if Tname_FD /= Invalid_FD then - Delete (Tname); - end if; + -- Delete the temporary file used in conjunction with linking + -- if one was created. See Process_Bind_File for details. - else - Error_Msg ("error when calling " & Linker_Path.all); - Exit_Program (E_Fatal); + if Tname_FD /= Invalid_FD then + Delete (Tname); end if; - end Call_Linker; - end Link_Step; - end if; + + else + Error_Msg ("error when calling " & Linker_Path.all); + Exit_Program (E_Fatal); + end if; + end Call_Linker; + end Link_Step; -- Only keep the binder output file and it's associated object -- file if compiling with the -g option. These files are only diff --git a/main/gcc/ada/gnatls.adb b/main/gcc/ada/gnatls.adb index 4a7c2176a62..3db4d617be9 100644 --- a/main/gcc/ada/gnatls.adb +++ b/main/gcc/ada/gnatls.adb @@ -129,6 +129,9 @@ procedure Gnatls is RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= switch + Exit_Status : Exit_Code_Type := E_Success; + -- Reset to E_Fatal if bad error found + ----------------------- -- Local Subprograms -- ----------------------- @@ -147,9 +150,9 @@ procedure Gnatls is Stamp : Time_Stamp_Type; Checksum : Word; Status : out File_Status); - -- Determine the file status (Status) of the file represented by FS - -- with the expected Stamp and checksum given as argument. FS will be - -- updated to the full file name if available. + -- Determine the file status (Status) of the file represented by FS with + -- the expected Stamp and checksum given as argument. FS will be updated + -- to the full file name if available. function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; -- Give the Sdep entry corresponding to the unit U in ali record A @@ -172,7 +175,7 @@ procedure Gnatls is -- Reset Print flags properly when selective output is chosen procedure Scan_Ls_Arg (Argv : String); - -- Scan and process lser specific arguments. Argv is a single argument + -- Scan and process user specific arguments (Argv is a single argument) procedure Search_RTS (Name : String); -- Find include and objects path for the RTS name. @@ -181,16 +184,14 @@ procedure Gnatls is -- Print usage message procedure Output_License_Information; - -- Output license statement, and if not found, output reference to - -- COPYING. + -- Output license statement, and if not found, output reference to COPYING function Image (Restriction : Restriction_Id) return String; -- Returns the capitalized image of Restriction function Normalize (Path : String) return String; - -- Returns a normalized path name, except on VMS where the argument Path - -- is returned, to keep the host pathname syntax. On Windows, the directory - -- separators are set to '\' in Normalize_Pathname. + -- Returns a normalized path name. On Windows, the directory separators are + -- set to '\' in Normalize_Pathname. ------------------------------------------ -- GNATDIST specific output subprograms -- @@ -836,11 +837,7 @@ procedure Gnatls is function Normalize (Path : String) return String is begin - if OpenVMS_On_Target then - return Path; - else - return Normalize_Pathname (Path); - end if; + return Normalize_Pathname (Path); end Normalize; -------------------------------- @@ -1629,8 +1626,8 @@ begin Osint.Add_Default_Search_Dirs; - -- Get the target parameters to know if the target is OpenVMS, but only if - -- switch -nostdinc was not specified. + -- Get the target parameters, but only if switch -nostdinc was not + -- specified. May not be needed any more, but is harmless. if not Opt.No_Stdinc then Get_Target_Parameters; @@ -1764,7 +1761,7 @@ begin Initialize_ALI; Initialize_ALI_Source; - -- Print out all library for which no ALI files can be located + -- Print out all libraries for which no ALI files can be located while More_Lib_Files loop Main_File := Next_Main_Lib_File; @@ -1782,6 +1779,7 @@ begin Write_Str (Name_Buffer (1 .. Name_Len)); Write_Char ('"'); -- " Write_Eol; + Exit_Status := E_Fatal; end if; else @@ -1792,7 +1790,6 @@ begin declare Discard : ALI_Id; - pragma Unreferenced (Discard); begin Discard := Scan_ALI @@ -1906,5 +1903,5 @@ begin -- All done. Set proper exit status Namet.Finalize; - Exit_Program (E_Success); + Exit_Program (Exit_Status); end Gnatls; diff --git a/main/gcc/ada/gnatname.adb b/main/gcc/ada/gnatname.adb index 47ed2e5dad5..82f32747948 100644 --- a/main/gcc/ada/gnatname.adb +++ b/main/gcc/ada/gnatname.adb @@ -30,7 +30,6 @@ with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Dynamic_Tables; with GNAT.OS_Lib; use GNAT.OS_Lib; -with Hostparm; with Opt; with Osint; use Osint; with Output; use Output; @@ -549,35 +548,31 @@ procedure Gnatname is begin -- Add the directory where gnatname is invoked in front of the -- path, if gnatname is invoked with directory information. - -- Only do this if the platform is not VMS, where the notion of path - -- does not really exist. - if not Hostparm.OpenVMS then - declare - Command : constant String := Command_Name; + declare + Command : constant String := Command_Name; - begin - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; - - begin - Setenv ("PATH", PATH); - end; - - exit; - end if; - end loop; - end; - end if; + begin + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + + PATH : constant String := + Absolute_Dir & + Path_Separator & + Getenv ("PATH").all; + + begin + Setenv ("PATH", PATH); + end; + + exit; + end if; + end loop; + end; -- Initialize tables @@ -585,12 +580,12 @@ begin declare New_Arguments : Argument_Data; pragma Warnings (Off, New_Arguments); - -- Declaring this defaulted initialized object ensures - -- that the new allocated component of table Arguments - -- is correctly initialized. + -- Declaring this defaulted initialized object ensures that the new + -- allocated component of table Arguments is correctly initialized. begin Arguments.Append (New_Arguments); end; + Patterns.Init (Arguments.Table (1).Directories); Patterns.Set_Last (Arguments.Table (1).Directories, 0); Patterns.Init (Arguments.Table (1).Name_Patterns); diff --git a/main/gcc/ada/gnatsym.adb b/main/gcc/ada/gnatsym.adb deleted file mode 100644 index 5a88994a4c4..00000000000 --- a/main/gcc/ada/gnatsym.adb +++ /dev/null @@ -1,359 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T S Y M -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This utility application creates symbol files in a format that is --- platform-dependent. - --- A symbol file is a text file that lists the symbols to be exported from --- a shared library. The format of a symbol file depends on the platform; --- it may be a simple enumeration of the symbol (one per line) or a more --- elaborate format (on VMS, for example). A symbol file may be used as an --- input to the platform linker when building a shared library. - --- This utility is not available on all platforms. It is currently supported --- only on OpenVMS. - --- gnatsym takes as parameters: --- - the name of the symbol file to create --- - (optional) the policy to create the symbol file --- - (optional) the name of the reference symbol file --- - the names of one or more object files where the symbols are found - -with Gnatvsn; use Gnatvsn; -with Osint; use Osint; -with Output; use Output; -with Symbols; use Symbols; -with Table; - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Text_IO; use Ada.Text_IO; - -with GNAT.Command_Line; use GNAT.Command_Line; -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.OS_Lib; use GNAT.OS_Lib; - -procedure Gnatsym is - - Empty_String : aliased String := ""; - Empty : constant String_Access := Empty_String'Unchecked_Access; - -- To initialize variables Reference and Version_String - - Copyright_Displayed : Boolean := False; - -- A flag to prevent multiple display of the Copyright notice - - Success : Boolean := True; - - Symbol_Policy : Policy := Autonomous; - - Verbose : Boolean := False; - -- True when -v switch is used - - Quiet : Boolean := False; - -- True when -q switch is used - - Symbol_File_Name : String_Access := null; - -- The name of the symbol file - - Reference_Symbol_File_Name : String_Access := Empty; - -- The name of the reference symbol file - - Version_String : String_Access := Empty; - -- The version of the library (used on VMS) - - type Object_File_Data is record - Path : String_Access; - Name : String_Access; - end record; - - package Object_Files is new Table.Table - (Table_Component_Type => Object_File_Data, - Table_Index_Type => Natural, - Table_Low_Bound => 0, - Table_Initial => 10, - Table_Increment => 100, - Table_Name => "Gnatsymb.Object_Files"); - -- A table to store the object file names - - Object_File : Natural := 0; - -- An index to traverse the Object_Files table - - procedure Display_Copyright; - -- Display Copyright notice - - procedure Parse_Cmd_Line; - -- Parse the command line switches and file names - - procedure Usage; - -- Display the usage - - ----------------------- - -- Display_Copyright -- - ----------------------- - - procedure Display_Copyright is - begin - if not Copyright_Displayed then - Write_Eol; - Write_Str ("GNATSYMB "); - Write_Str (Gnat_Version_String); - Write_Eol; - Write_Str ("Copyright 2003-2004 Free Software Foundation, Inc"); - Write_Eol; - Copyright_Displayed := True; - end if; - end Display_Copyright; - - -------------------- - -- Parse_Cmd_Line -- - -------------------- - - procedure Parse_Cmd_Line is - begin - loop - case GNAT.Command_Line.Getopt ("c C D q r: R s: v V:") is - when ASCII.NUL => - exit; - - when 'c' => - Symbol_Policy := Compliant; - - when 'C' => - Symbol_Policy := Controlled; - - when 'D' => - Symbol_Policy := Direct; - - when 'q' => - Quiet := True; - - when 'r' => - Reference_Symbol_File_Name := - new String'(GNAT.Command_Line.Parameter); - - when 'R' => - Symbol_Policy := Restricted; - - when 's' => - Symbol_File_Name := new String'(GNAT.Command_Line.Parameter); - - when 'v' => - Verbose := True; - - when 'V' => - Version_String := new String'(GNAT.Command_Line.Parameter); - - when others => - Fail ("invalid switch: " & Full_Switch); - end case; - end loop; - - -- Get the object file names and put them in the table in alphabetical - -- order of base names. - - loop - declare - S : constant String_Access := - new String'(GNAT.Command_Line.Get_Argument); - - begin - exit when S'Length = 0; - - Object_Files.Increment_Last; - - declare - Base : constant String := Base_Name (S.all); - Last : constant Positive := Object_Files.Last; - J : Positive; - - begin - J := 1; - while J < Last loop - if Object_Files.Table (J).Name.all > Base then - Object_Files.Table (J + 1 .. Last) := - Object_Files.Table (J .. Last - 1); - exit; - end if; - - J := J + 1; - end loop; - - Object_Files.Table (J) := (S, new String'(Base)); - end; - end; - end loop; - exception - when Invalid_Switch => - Usage; - Fail ("invalid switch : " & Full_Switch); - end Parse_Cmd_Line; - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - Write_Line ("gnatsym [options] object_file {object_file}"); - Write_Eol; - Write_Line (" -c Compliant symbol policy"); - Write_Line (" -C Controlled symbol policy"); - Write_Line (" -q Quiet mode"); - Write_Line (" -r Reference symbol file name"); - Write_Line (" -R Restricted symbol policy"); - Write_Line (" -s Symbol file name"); - Write_Line (" -v Verbose mode"); - Write_Line (" -V Version"); - Write_Eol; - Write_Line ("Specifying a symbol file with -s is compulsory"); - Write_Eol; - end Usage; - --- Start of processing of Gnatsym - -begin - -- Initialize Object_Files table - - Object_Files.Set_Last (0); - - -- Parse the command line - - Parse_Cmd_Line; - - if Verbose then - Display_Copyright; - end if; - - -- If there is no symbol file or no object files on the command line, - -- display the usage and exit with an error status. - - if Symbol_File_Name = null or else Object_Files.Last = 0 then - Usage; - OS_Exit (1); - - -- When symbol policy is direct, simply copy the reference symbol file to - -- the symbol file. - - elsif Symbol_Policy = Direct then - declare - File_In : Ada.Text_IO.File_Type; - File_Out : Ada.Text_IO.File_Type; - Line : String (1 .. 1_000); - Last : Natural; - - begin - begin - Open (File_In, In_File, Reference_Symbol_File_Name.all); - - exception - when X : others => - if not Quiet then - Put_Line - ("could not open """ & - Reference_Symbol_File_Name.all - & """"); - Put_Line (Exception_Message (X)); - end if; - - OS_Exit (1); - end; - - begin - Create (File_Out, Out_File, Symbol_File_Name.all); - - exception - when X : others => - if not Quiet then - Put_Line - ("could not create """ & Symbol_File_Name.all & """"); - Put_Line (Exception_Message (X)); - end if; - - OS_Exit (1); - end; - - while not End_Of_File (File_In) loop - Get_Line (File_In, Line, Last); - Put_Line (File_Out, Line (1 .. Last)); - end loop; - - Close (File_In); - Close (File_Out); - end; - - else - if Verbose then - Write_Str ("Initializing symbol file """); - Write_Str (Symbol_File_Name.all); - Write_Line (""""); - end if; - - -- Initialize symbol file and, if specified, read reference file - - Symbols.Initialize - (Symbol_File => Symbol_File_Name.all, - Reference => Reference_Symbol_File_Name.all, - Symbol_Policy => Symbol_Policy, - Quiet => Quiet, - Version => Version_String.all, - Success => Success); - - -- Process the object files in order. Stop as soon as there is - -- something wrong. - - Object_File := 0; - - while Success and then Object_File < Object_Files.Last loop - Object_File := Object_File + 1; - - if Verbose then - Write_Str ("Processing object file """); - Write_Str (Object_Files.Table (Object_File).Path.all); - Write_Line (""""); - end if; - - Processing.Process - (Object_Files.Table (Object_File).Path.all, - Success); - end loop; - - -- Finalize the symbol file - - if Success then - if Verbose then - Write_Str ("Finalizing """); - Write_Str (Symbol_File_Name.all); - Write_Line (""""); - end if; - - Finalize (Quiet, Success); - end if; - - -- Fail if there was anything wrong - - if not Success then - Fail ("unable to build symbol file"); - end if; - end if; -end Gnatsym; diff --git a/main/gcc/ada/hostparm.ads b/main/gcc/ada/hostparm.ads index d868f2fa724..253c3be3c4c 100644 --- a/main/gcc/ada/hostparm.ads +++ b/main/gcc/ada/hostparm.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,14 +41,6 @@ package Hostparm is -- HOST Parameters -- --------------------- - Gnat_VMSp : Integer; - pragma Import (C, Gnat_VMSp, "__gnat_vmsp"); - - OpenVMS : Boolean := Gnat_VMSp /= 0; - -- Set True for OpenVMS host. See also OpenVMS target boolean in - -- system-vms.ads and system-vms_64.ads and OpenVMS_On_Target boolean in - -- Targparm. This is not a constant, because it can be modified by -gnatdm. - Direct_Separator : constant Character; pragma Import (C, Direct_Separator, "__gnat_dir_separator"); Normalized_CWD : constant String := "." & Direct_Separator; @@ -78,9 +70,4 @@ package Hostparm is -- If set to true, gnatbind will exclude from consideration all -- non-existent .o files. - Max_Debug_Name_Length : constant := 256; - -- If a generated qualified debug name exceeds this length, then it - -- is automatically compressed, regardless of the setting of the - -- Compress_Debug_Names switch controlled by -gnatC. - end Hostparm; diff --git a/main/gcc/ada/i-cpp.ads b/main/gcc/ada/i-cpp.ads deleted file mode 100644 index 27db1c2b1fd..00000000000 --- a/main/gcc/ada/i-cpp.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . C P P -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Missing package comment ??? - -with Ada.Tags; - -package Interfaces.CPP is - pragma Elaborate_Body; - -- We have a dummy body to deal with bootstrap path issues - - subtype Vtable_Ptr is Ada.Tags.Tag; - - -- These need commenting (this is not an RM package) ??? - - function Expanded_Name (T : Vtable_Ptr) return String - renames Ada.Tags.Expanded_Name; - - function External_Tag (T : Vtable_Ptr) return String - renames Ada.Tags.External_Tag; - -end Interfaces.CPP; diff --git a/main/gcc/ada/i-cstrea-vms.adb b/main/gcc/ada/i-cstrea-vms.adb deleted file mode 100644 index 85e6f56b31a..00000000000 --- a/main/gcc/ada/i-cstrea-vms.adb +++ /dev/null @@ -1,253 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version - -with Ada.Unchecked_Conversion; -package body Interfaces.C_Streams is - - use type System.CRTL.size_t; - - -- As the functions fread, fwrite and setvbuf are too big to be inlined, - -- they are just wrappers to the following implementation functions. - - function fread_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function fread_impl - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function fwrite_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function setvbuf_impl - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int; - - ------------ - -- fread -- - ------------ - - function fread_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - Get_Count : size_t := 0; - - type Buffer_Type is array (size_t range 1 .. count, - size_t range 1 .. size) of Character; - type Buffer_Access is access Buffer_Type; - function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); - - BA : constant Buffer_Access := To_BA (buffer); - Ch : int; - - begin - -- This Fread goes with the Fwrite below. The C library fread sometimes - -- can't read fputc generated files. - - for C in 1 .. count loop - for S in 1 .. size loop - Ch := fgetc (stream); - - if Ch = EOF then - return Get_Count; - end if; - - BA.all (C, S) := Character'Val (Ch); - end loop; - - Get_Count := Get_Count + 1; - end loop; - - return Get_Count; - end fread_impl; - - function fread_impl - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - Get_Count : size_t := 0; - - type Buffer_Type is array (size_t range 1 .. count, - size_t range 1 .. size) of Character; - type Buffer_Access is access Buffer_Type; - function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); - - BA : constant Buffer_Access := To_BA (buffer); - Ch : int; - - begin - -- This Fread goes with the Fwrite below. The C library fread sometimes - -- can't read fputc generated files. - - for C in 1 + index .. count + index loop - for S in 1 .. size loop - Ch := fgetc (stream); - - if Ch = EOF then - return Get_Count; - end if; - - BA.all (C, S) := Character'Val (Ch); - end loop; - - Get_Count := Get_Count + 1; - end loop; - - return Get_Count; - end fread_impl; - - function fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return fread_impl (buffer, size, count, stream); - end fread; - - function fread - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return fread_impl (buffer, index, size, count, stream); - end fread; - - ------------ - -- fwrite -- - ------------ - - function fwrite_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - Put_Count : size_t := 0; - - type Buffer_Type is array (size_t range 1 .. count, - size_t range 1 .. size) of Character; - type Buffer_Access is access Buffer_Type; - function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); - - BA : constant Buffer_Access := To_BA (buffer); - - begin - -- Fwrite on VMS has the undesirable effect of always generating at - -- least one record of output per call, regardless of buffering. To - -- get around this, we do multiple fputc calls instead. - - for C in 1 .. count loop - for S in 1 .. size loop - if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then - return Put_Count; - end if; - end loop; - - Put_Count := Put_Count + 1; - end loop; - - return Put_Count; - end fwrite_impl; - - function fwrite - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return fwrite_impl (buffer, size, count, stream); - end fwrite; - - ------------- - -- setvbuf -- - ------------- - - function setvbuf_impl - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int - is - use type System.Address; - - begin - -- In order for the above fwrite hack to work, we must always buffer - -- stdout and stderr. Is_regular_file on VMS cannot detect when - -- these are redirected to a file, so checking for that condition - -- doesn't help. - - if mode = IONBF - and then (stream = stdout or else stream = stderr) - then - return System.CRTL.setvbuf - (stream, buffer, IOLBF, System.CRTL.size_t (size)); - else - return System.CRTL.setvbuf - (stream, buffer, mode, System.CRTL.size_t (size)); - end if; - end setvbuf_impl; - - function setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int - is - begin - return setvbuf_impl (stream, buffer, mode, size); - end setvbuf; - -end Interfaces.C_Streams; diff --git a/main/gcc/ada/i-cstrea.adb b/main/gcc/ada/i-cstrea.adb index e072b0d414e..d831206b47b 100644 --- a/main/gcc/ada/i-cstrea.adb +++ b/main/gcc/ada/i-cstrea.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 @@ -- -- ------------------------------------------------------------------------------ --- This is the default version which just calls the C versions directly --- Note: the reason that we provide for specialization here is that on --- some systems, notably VMS, we may need to worry about buffering. - with Ada.Unchecked_Conversion; package body Interfaces.C_Streams is diff --git a/main/gcc/ada/i-cstrea.ads b/main/gcc/ada/i-cstrea.ads index 48fbfc45bdc..5927e5f95c2 100644 --- a/main/gcc/ada/i-cstrea.ads +++ b/main/gcc/ada/i-cstrea.ads @@ -43,6 +43,7 @@ package Interfaces.C_Streams is subtype long is System.CRTL.long; subtype size_t is System.CRTL.size_t; subtype ssize_t is System.CRTL.ssize_t; + subtype int64 is System.CRTL.int64; subtype voids is System.Address; NULL_Stream : constant FILEs; @@ -107,9 +108,8 @@ package Interfaces.C_Streams is function fopen (filename : chars; mode : chars; - encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8; - vms_form : chars := System.Null_Address) return FILEs - renames System.CRTL.fopen; + encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) + return FILEs renames System.CRTL.fopen; -- Note: to maintain target independence, use text_translation_required, -- a boolean variable defined in sysdep.c to deal with the target -- dependent text translation requirement. If this variable is set, @@ -147,9 +147,8 @@ package Interfaces.C_Streams is (filename : chars; mode : chars; stream : FILEs; - encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8; - vms_form : chars := System.Null_Address) return FILEs - renames System.CRTL.freopen; + encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) + return FILEs renames System.CRTL.freopen; function fseek (stream : FILEs; @@ -159,14 +158,14 @@ package Interfaces.C_Streams is function fseek64 (stream : FILEs; - offset : ssize_t; + offset : int64; origin : int) return int renames System.CRTL.fseek64; function ftell (stream : FILEs) return long renames System.CRTL.ftell; - function ftell64 (stream : FILEs) return ssize_t + function ftell64 (stream : FILEs) return int64 renames System.CRTL.ftell64; function fwrite diff --git a/main/gcc/ada/impunit.adb b/main/gcc/ada/impunit.adb index 750326fd1ae..69356cbfb34 100644 --- a/main/gcc/ada/impunit.adb +++ b/main/gcc/ada/impunit.adb @@ -273,6 +273,7 @@ package body Impunit is ("g-expect", F), -- GNAT.Expect ("g-exptty", F), -- GNAT.Expect.TTY ("g-flocon", F), -- GNAT.Float_Control + ("g-forstr", F), -- GNAT.Formatted_String ("g-heasor", F), -- GNAT.Heap_Sort ("g-hesora", F), -- GNAT.Heap_Sort_A ("g-hesorg", F), -- GNAT.Heap_Sort_G @@ -344,7 +345,6 @@ package body Impunit is ("i-cexten", F), -- Interfaces.C.Extensions ("i-cil ", F), -- Interfaces.CIL ("i-cilobj", F), -- Interfaces.CIL.Object - ("i-cpp ", F), -- Interfaces.CPP ("i-cstrea", F), -- Interfaces.C.Streams ("i-java ", F), -- Interfaces.Java ("i-javjni", F), -- Interfaces.Java.JNI diff --git a/main/gcc/ada/indepsw-aix.adb b/main/gcc/ada/indepsw-aix.adb index 8eaa382cac4..61bb54c843a 100644 --- a/main/gcc/ada/indepsw-aix.adb +++ b/main/gcc/ada/indepsw-aix.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (AIX version) -- -- -- --- Copyright (C) 2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/indepsw-gnu.adb b/main/gcc/ada/indepsw-gnu.adb index c81270ed533..145f6a2f2e0 100644 --- a/main/gcc/ada/indepsw-gnu.adb +++ b/main/gcc/ada/indepsw-gnu.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (GNU version) -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/indepsw-mingw.adb b/main/gcc/ada/indepsw-mingw.adb index 7632cf7f39e..819652d242b 100644 --- a/main/gcc/ada/indepsw-mingw.adb +++ b/main/gcc/ada/indepsw-mingw.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Windows version) -- -- -- --- Copyright (C) 2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/indepsw.adb b/main/gcc/ada/indepsw.adb index 8439075fa9d..631367500df 100644 --- a/main/gcc/ada/indepsw.adb +++ b/main/gcc/ada/indepsw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/init.c b/main/gcc/ada/init.c index 587638ba148..ad8023594ef 100644 --- a/main/gcc/ada/init.c +++ b/main/gcc/ada/init.c @@ -1730,7 +1730,7 @@ __gnat_inum_to_ivec (int num) } #endif -#if !defined(__alpha_vxworks) && (_WRS_VXWORKS_MAJOR != 6) && !defined(__RTP__) +#if !defined(__alpha_vxworks) && ((_WRS_VXWORKS_MAJOR != 6) && (_WRS_VXWORKS_MAJOR != 7)) && !defined(__RTP__) /* getpid is used by s-parint.adb, but is not defined by VxWorks, except on Alpha VxWorks and VxWorks 6.x (including RTPs). */ @@ -1911,7 +1911,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) sigdelset (&mask, sig); sigprocmask (SIG_SETMASK, &mask, NULL); -#if (defined (__ARMEL__) || defined (__PPC__)) && defined(_WRS_KERNEL) +#if defined (__ARMEL__) || defined (__PPC__) /* On PowerPC, kernel mode, we process signals through a Call Frame Info trampoline, voiding the need for myriads of fallback_frame_state variants in the ZCX runtime. We have no simple way to distinguish ZCX diff --git a/main/gcc/ada/inline.adb b/main/gcc/ada/inline.adb index 99e73e13a09..c2e0f18a0ea 100644 --- a/main/gcc/ada/inline.adb +++ b/main/gcc/ada/inline.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,28 +24,69 @@ ------------------------------------------------------------------------------ with Atree; use Atree; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Expander; use Expander; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; +with Exp_Util; use Exp_Util; with Fname; use Fname; with Fname.UF; use Fname.UF; with Lib; use Lib; with Namet; use Namet; +with Nmake; use Nmake; with Nlists; use Nlists; +with Output; use Output; with Sem_Aux; use Sem_Aux; with Sem_Ch8; use Sem_Ch8; with Sem_Ch10; use Sem_Ch10; with Sem_Ch12; use Sem_Ch12; +with Sem_Prag; use Sem_Prag; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Uname; use Uname; +with Tbuild; use Tbuild; package body Inline is + Check_Inlining_Restrictions : constant Boolean := True; + -- In the following cases the frontend rejects inlining because they + -- are not handled well by the backend. This variable facilitates + -- disabling these restrictions to evaluate future versions of the + -- GCC backend in which some of the restrictions may be supported. + -- + -- - subprograms that have: + -- - nested subprograms + -- - instantiations + -- - package declarations + -- - task or protected object declarations + -- - some of the following statements: + -- - abort + -- - asynchronous-select + -- - conditional-entry-call + -- - delay-relative + -- - delay-until + -- - selective-accept + -- - timed-entry-call + + Inlined_Calls : Elist_Id; + -- List of frontend inlined calls + + Backend_Calls : Elist_Id; + -- List of inline calls passed to the backend + + Backend_Inlined_Subps : Elist_Id; + -- List of subprograms inlined by the backend + + Backend_Not_Inlined_Subps : Elist_Id; + -- List of subprograms that cannot be inlined by the backend + -------------------- -- Inlined Bodies -- -------------------- @@ -100,9 +141,9 @@ package body Inline is Next : Succ_Index; end record; - -- The following table stores list elements for the successor lists. - -- These lists cannot be chained directly through entries in the Inlined - -- table, because a given subprogram can appear in several such lists. + -- The following table stores list elements for the successor lists. These + -- lists cannot be chained directly through entries in the Inlined table, + -- because a given subprogram can appear in several such lists. package Successors is new Table.Table ( Table_Component_Type => Succ_Info, @@ -133,49 +174,61 @@ package body Inline is -- Local Subprograms -- ----------------------- - function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id; - pragma Inline (Get_Code_Unit_Entity); - -- Return the entity node for the unit containing E. Always return - -- the spec for a package. - - function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; - -- Return True if E is in the main unit or its spec or in a subunit - procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty); -- Make two entries in Inlined table, for an inlined subprogram being -- called, and for the inlined subprogram that contains the call. If -- the call is in the main compilation unit, Caller is Empty. + procedure Add_Inlined_Subprogram (Index : Subp_Index); + -- Add the subprogram to the list of inlined subprogram for the unit + function Add_Subp (E : Entity_Id) return Subp_Index; -- Make entry in Inlined table for subprogram E, or return table index -- that already holds E. + function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id; + pragma Inline (Get_Code_Unit_Entity); + -- Return the entity node for the unit containing E. Always return the spec + -- for a package. + function Has_Initialized_Type (E : Entity_Id) return Boolean; -- If a candidate for inlining contains type declarations for types with -- non-trivial initialization procedures, they are not worth inlining. - function Is_Nested (E : Entity_Id) return Boolean; - -- If the function is nested inside some other function, it will - -- always be compiled if that function is, so don't add it to the - -- inline list. We cannot compile a nested function outside the - -- scope of the containing function anyway. This is also the case if - -- the function is defined in a task body or within an entry (for - -- example, an initialization procedure). + function Has_Single_Return (N : Node_Id) return Boolean; + -- In general we cannot inline functions that return unconstrained type. + -- However, we can handle such functions if all return statements return a + -- local variable that is the only declaration in the body of the function. + -- In that case the call can be replaced by that local variable as is done + -- for other inlined calls. - procedure Add_Inlined_Subprogram (Index : Subp_Index); - -- Add the subprogram to the list of inlined subprogram for the unit + function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; + -- Return True if E is in the main unit or its spec or in a subunit + + function Is_Nested (E : Entity_Id) return Boolean; + -- If the function is nested inside some other function, it will always + -- be compiled if that function is, so don't add it to the inline list. + -- We cannot compile a nested function outside the scope of the containing + -- function anyway. This is also the case if the function is defined in a + -- task body or within an entry (for example, an initialization procedure). + + procedure Remove_Pragmas (Bod : Node_Id); + -- A pragma Unreferenced or pragma Unmodified that mentions a formal + -- parameter has no meaning when the body is inlined and the formals + -- are rewritten. Remove it from body to inline. The analysis of the + -- non-inlined body will handle the pragma properly. ------------------------------ -- Deferred Cleanup Actions -- ------------------------------ -- The cleanup actions for scopes that contain instantiations is delayed - -- until after expansion of those instantiations, because they may - -- contain finalizable objects or tasks that affect the cleanup code. - -- A scope that contains instantiations only needs to be finalized once, - -- even if it contains more than one instance. We keep a list of scopes - -- that must still be finalized, and call cleanup_actions after all the - -- instantiations have been completed. + -- until after expansion of those instantiations, because they may contain + -- finalizable objects or tasks that affect the cleanup code. A scope + -- that contains instantiations only needs to be finalized once, even + -- if it contains more than one instance. We keep a list of scopes + -- that must still be finalized, and call cleanup_actions after all + -- the instantiations have been completed. To_Clean : Elist_Id; @@ -291,9 +344,7 @@ package body Inline is while Scope (Scop) /= Standard_Standard and then not Is_Child_Unit (Scop) loop - if Is_Overloadable (Scop) - and then Is_Inlined (Scop) - then + if Is_Overloadable (Scop) and then Is_Inlined (Scop) then Add_Call (E, Scop); if Inline_Level = 1 then @@ -369,6 +420,17 @@ package body Inline is 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; end if; end; @@ -397,6 +459,13 @@ package body Inline is -- -- This procedure must be carefully coordinated with the back end. + procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id); + -- Append Subp to the list of subprograms inlined by the backend + + procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id); + -- Append Subp to the list of subprograms that cannot be inlined by + -- the backend. + ---------------------------- -- Back_End_Cannot_Inline -- ---------------------------- @@ -422,9 +491,9 @@ package body Inline is end if; if Present - (Exception_Handlers - (Handled_Statement_Sequence - (Unit_Declaration_Node (Corresponding_Body (Decl))))) + (Exception_Handlers + (Handled_Statement_Sequence + (Unit_Declaration_Node (Corresponding_Body (Decl))))) then return True; end if; @@ -443,6 +512,24 @@ package body Inline is return False; end Back_End_Cannot_Inline; + ----------------------------------------- + -- Register_Backend_Inlined_Subprogram -- + ----------------------------------------- + + procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is + begin + Append_New_Elmt (Subp, To => Backend_Inlined_Subps); + end Register_Backend_Inlined_Subprogram; + + --------------------------------------------- + -- Register_Backend_Not_Inlined_Subprogram -- + --------------------------------------------- + + procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is + begin + Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps); + end Register_Backend_Not_Inlined_Subprogram; + -- Start of processing for Add_Inlined_Subprogram begin @@ -454,16 +541,19 @@ package body Inline is if Is_Inlined (E) and then (Is_Inlined (Pack) - or else Is_Generic_Instance (Pack) - or else Is_Internal (E)) + or else Is_Generic_Instance (Pack) + or else Is_Internal (E)) and then not In_Main_Unit_Or_Subunit (E) and then not Is_Nested (E) and then not Has_Initialized_Type (E) then if Back_End_Cannot_Inline (E) then Set_Is_Inlined (E, False); + Register_Backend_Not_Inlined_Subprogram (E); else + Register_Backend_Inlined_Subprogram (E); + if No (Last_Inlined) then Set_First_Inlined_Subprogram (Cunit (Main_Unit), E); else @@ -472,6 +562,8 @@ package body Inline is Last_Inlined := E; end if; + else + Register_Backend_Not_Inlined_Subprogram (E); end if; Inlined.Table (Index).Listed := True; @@ -820,237 +912,2831 @@ package body Inline is end if; end Analyze_Inlined_Bodies; - ----------------------------- - -- Check_Body_For_Inlining -- - ----------------------------- + -------------------------- + -- Build_Body_To_Inline -- + -------------------------- - procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is - Bname : Unit_Name_Type; - E : Entity_Id; - OK : Boolean; + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + Analysis_Status : constant Boolean := Full_Analysis; + Original_Body : Node_Id; + Body_To_Analyze : Node_Id; + Max_Size : constant := 10; + + function Has_Pending_Instantiation return Boolean; + -- If some enclosing body contains instantiations that appear before + -- the corresponding generic body, the enclosing body has a freeze node + -- so that it can be elaborated after the generic itself. This might + -- conflict with subsequent inlinings, so that it is unsafe to try to + -- inline in such a case. + + function Has_Single_Return_In_GNATprove_Mode return Boolean; + -- This function is called only in GNATprove mode, and it returns + -- True if the subprogram has no return statement or a single return + -- statement as last statement. + + function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; + -- If the body of the subprogram includes a call that returns an + -- unconstrained type, the secondary stack is involved, and it + -- is not worth inlining. + + ------------------------------- + -- Has_Pending_Instantiation -- + ------------------------------- + + function Has_Pending_Instantiation return Boolean is + S : Entity_Id; - begin - if Is_Compilation_Unit (P) - and then not Is_Generic_Instance (P) - then - Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); + begin + S := Current_Scope; + while Present (S) loop + if Is_Compilation_Unit (S) + or else Is_Child_Unit (S) + then + return False; - E := First_Entity (P); - while Present (E) loop - if Has_Pragma_Inline_Always (E) - or else (Front_End_Inlining and then Has_Pragma_Inline (E)) + elsif Ekind (S) = E_Package + and then Has_Forward_Instantiation (S) then - if not Is_Loaded (Bname) then - Load_Needed_Body (N, OK); + return True; + end if; - if OK then + S := Scope (S); + end loop; - -- Check we are not trying to inline a parent whose body - -- depends on a child, when we are compiling the body of - -- the child. Otherwise we have a potential elaboration - -- circularity with inlined subprograms and with - -- Taft-Amendment types. + return False; + end Has_Pending_Instantiation; - declare - Comp : Node_Id; -- Body just compiled - Child_Spec : Entity_Id; -- Spec of main unit - Ent : Entity_Id; -- For iteration - With_Clause : Node_Id; -- Context of body. + ----------------------------------------- + -- Has_Single_Return_In_GNATprove_Mode -- + ----------------------------------------- - begin - if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body - and then Present (Body_Entity (P)) - then - Child_Spec := - Defining_Entity - ((Unit (Library_Unit (Cunit (Main_Unit))))); + function Has_Single_Return_In_GNATprove_Mode return Boolean is + Last_Statement : Node_Id := Empty; - Comp := - Parent (Unit_Declaration_Node (Body_Entity (P))); + function Check_Return (N : Node_Id) return Traverse_Result; + -- Returns OK on node N if this is not a return statement different + -- from the last statement in the subprogram. - -- Check whether the context of the body just - -- compiled includes a child of itself, and that - -- child is the spec of the main compilation. + ------------------ + -- Check_Return -- + ------------------ - With_Clause := First (Context_Items (Comp)); - while Present (With_Clause) loop - if Nkind (With_Clause) = N_With_Clause - and then - Scope (Entity (Name (With_Clause))) = P - and then - Entity (Name (With_Clause)) = Child_Spec - then - Error_Msg_Node_2 := Child_Spec; - Error_Msg_NE - ("body of & depends on child unit&??", - With_Clause, P); - Error_Msg_N - ("\subprograms in body cannot be inlined??", - With_Clause); + 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; - -- Disable further inlining from this unit, - -- and keep Taft-amendment types incomplete. + else + return OK; + end if; + end Check_Return; - Ent := First_Entity (P); - while Present (Ent) loop - if Is_Type (Ent) - and then Has_Completion_In_Body (Ent) - then - Set_Full_View (Ent, Empty); + function Check_All_Returns is new Traverse_Func (Check_Return); - elsif Is_Subprogram (Ent) then - Set_Is_Inlined (Ent, False); - end if; + -- Start of processing for Has_Single_Return_In_GNATprove_Mode - Next_Entity (Ent); - end loop; + begin + -- Retrieve last statement inside possible block statements - return; - end if; + Last_Statement := Last (Statements (Handled_Statement_Sequence (N))); - Next (With_Clause); - end loop; - end if; - end; + while Nkind (Last_Statement) = N_Block_Statement loop + Last_Statement := + Last (Statements (Handled_Statement_Sequence (Last_Statement))); + end loop; - elsif Ineffective_Inline_Warnings then - Error_Msg_Unit_1 := Bname; - Error_Msg_N - ("unable to inline subprograms defined in $??", P); - Error_Msg_N ("\body not found??", P); - return; - end if; - end if; + -- Check that the last statement is the only possible return + -- statement in the subprogram. - return; + return Check_All_Returns (N) = OK; + end Has_Single_Return_In_GNATprove_Mode; + + -------------------------- + -- Uses_Secondary_Stack -- + -------------------------- + + function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is + function Check_Call (N : Node_Id) return Traverse_Result; + -- Look for function calls that return an unconstrained type + + ---------------- + -- Check_Call -- + ---------------- + + function Check_Call (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Function_Call + and then Is_Entity_Name (Name (N)) + and then Is_Composite_Type (Etype (Entity (Name (N)))) + and then not Is_Constrained (Etype (Entity (Name (N)))) + then + Cannot_Inline + ("cannot inline & (call returns unconstrained type)?", + N, Spec_Id); + return Abandon; + else + return OK; end if; + end Check_Call; - Next_Entity (E); - end loop; - end if; - end Check_Body_For_Inlining; + function Check_Calls is new Traverse_Func (Check_Call); - -------------------- - -- Cleanup_Scopes -- - -------------------- + begin + return Check_Calls (Bod) = Abandon; + end Uses_Secondary_Stack; - procedure Cleanup_Scopes is - Elmt : Elmt_Id; - Decl : Node_Id; - Scop : Entity_Id; + -- Start of processing for Build_Body_To_Inline begin - Elmt := First_Elmt (To_Clean); - while Present (Elmt) loop - Scop := Node (Elmt); + -- Return immediately if done already - if Ekind (Scop) = E_Entry then - Scop := Protected_Body_Subprogram (Scop); + if Nkind (Decl) = N_Subprogram_Declaration + and then Present (Body_To_Inline (Decl)) + then + return; - elsif Is_Subprogram (Scop) - and then Is_Protected_Type (Scope (Scop)) - and then Present (Protected_Body_Subprogram (Scop)) - then - -- If a protected operation contains an instance, its - -- cleanup operations have been delayed, and the subprogram - -- has been rewritten in the expansion of the enclosing - -- protected body. It is the corresponding subprogram that - -- may require the cleanup operations, so propagate the - -- information that triggers cleanup activity. + -- Subprograms that have return statements in the middle of the body are + -- inlined with gotos. GNATprove does not currently support gotos, so + -- we prevent such inlining. - Set_Uses_Sec_Stack - (Protected_Body_Subprogram (Scop), - Uses_Sec_Stack (Scop)); + elsif GNATprove_Mode + and then not Has_Single_Return_In_GNATprove_Mode + then + Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id); + return; - Scop := Protected_Body_Subprogram (Scop); + -- Functions that return unconstrained composite types require + -- secondary stack handling, and cannot currently be inlined, unless + -- all return statements return a local variable that is the first + -- local declaration in the body. + + elsif Ekind (Spec_Id) = E_Function + and then not Is_Scalar_Type (Etype (Spec_Id)) + and then not Is_Access_Type (Etype (Spec_Id)) + and then not Is_Constrained (Etype (Spec_Id)) + then + if not Has_Single_Return (N) then + Cannot_Inline + ("cannot inline & (unconstrained return type)?", N, Spec_Id); + return; end if; - if Ekind (Scop) = E_Block then - Decl := Parent (Block_Node (Scop)); + -- Ditto for functions that return controlled types, where controlled + -- actions interfere in complex ways with inlining. - else - Decl := Unit_Declaration_Node (Scop); + elsif Ekind (Spec_Id) = E_Function + and then Needs_Finalization (Etype (Spec_Id)) + then + Cannot_Inline + ("cannot inline & (controlled return type)?", N, Spec_Id); + return; + end if; - if Nkind (Decl) = N_Subprogram_Declaration - or else Nkind (Decl) = N_Task_Type_Declaration - or else Nkind (Decl) = N_Subprogram_Body_Stub - then - Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); - end if; + if Present (Declarations (N)) + and then Has_Excluded_Declaration (Spec_Id, Declarations (N)) + then + return; + end if; + + if Present (Handled_Statement_Sequence (N)) then + if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers (Handled_Statement_Sequence (N))), + Spec_Id); + return; + + elsif Has_Excluded_Statement + (Spec_Id, Statements (Handled_Statement_Sequence (N))) + then + return; end if; + end if; - Push_Scope (Scop); - Expand_Cleanup_Actions (Decl); - End_Scope; + -- We do not inline a subprogram that is too large, unless it is marked + -- Inline_Always or we are in GNATprove mode. This pragma does not + -- suppress the other checks on inlining (forbidden declarations, + -- handlers, etc). - Elmt := Next_Elmt (Elmt); - end loop; - end Cleanup_Scopes; + if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode) + and then List_Length + (Statements (Handled_Statement_Sequence (N))) > Max_Size + then + Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id); + return; + end if; - -------------------------- - -- Get_Code_Unit_Entity -- - -------------------------- + if Has_Pending_Instantiation then + Cannot_Inline + ("cannot inline& (forward instance within enclosing body)?", + N, Spec_Id); + return; + end if; - function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is - Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E)); + -- Within an instance, the body to inline must be treated as a nested + -- generic, so that the proper global references are preserved. - begin - if Ekind (Unit) = E_Package_Body then - Unit := Spec_Entity (Unit); + -- Note that we do not do this at the library level, because it is not + -- needed, and furthermore this causes trouble if front end inlining + -- is activated (-gnatN). + + if In_Instance and then Scope (Current_Scope) /= Standard_Standard then + Save_Env (Scope (Current_Scope), Scope (Current_Scope)); + Original_Body := Copy_Generic_Node (N, Empty, True); + else + Original_Body := Copy_Separate_Tree (N); end if; - return Unit; - end Get_Code_Unit_Entity; + -- We need to capture references to the formals in order to substitute + -- the actuals at the point of inlining, i.e. instantiation. To treat + -- the formals as globals to the body to inline, we nest it within a + -- dummy parameterless subprogram, declared within the real one. To + -- avoid generating an internal name (which is never public, and which + -- affects serial numbers of other generated names), we use an internal + -- symbol that cannot conflict with user declarations. - -------------------------- - -- Has_Initialized_Type -- - -------------------------- + Set_Parameter_Specifications (Specification (Original_Body), No_List); + Set_Defining_Unit_Name + (Specification (Original_Body), + Make_Defining_Identifier (Sloc (N), Name_uParent)); + Set_Corresponding_Spec (Original_Body, Empty); - function Has_Initialized_Type (E : Entity_Id) return Boolean is - E_Body : constant Node_Id := Get_Subprogram_Body (E); - Decl : Node_Id; + -- Remove those pragmas that have no meaining in an inlined body. - begin - if No (E_Body) then -- imported subprogram - return False; + Remove_Pragmas (Original_Body); - else - Decl := First (Declarations (E_Body)); - while Present (Decl) loop + Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); - if Nkind (Decl) = N_Full_Type_Declaration - and then Present (Init_Proc (Defining_Identifier (Decl))) - then - return True; - end if; + -- Set return type of function, which is also global and does not need + -- to be resolved. - Next (Decl); - end loop; + if Ekind (Spec_Id) = E_Function then + Set_Result_Definition (Specification (Body_To_Analyze), + New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); end if; - return False; - end Has_Initialized_Type; + if No (Declarations (N)) then + Set_Declarations (N, New_List (Body_To_Analyze)); + else + Append (Body_To_Analyze, Declarations (N)); + end if; - ----------------------------- - -- In_Main_Unit_Or_Subunit -- - ----------------------------- + -- The body to inline is pre-analyzed. In GNATprove mode we must + -- disable full analysis as well so that light expansion does not + -- take place either, and name resolution is unaffected. - function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is - Comp : Node_Id := Cunit (Get_Code_Unit (E)); + Expander_Mode_Save_And_Set (False); + Full_Analysis := False; - begin - -- Check whether the subprogram or package to inline is within the main - -- unit or its spec or within a subunit. In either case there are no - -- additional bodies to process. If the subprogram appears in a parent - -- of the current unit, the check on whether inlining is possible is - -- done in Analyze_Inlined_Bodies. + Analyze (Body_To_Analyze); + Push_Scope (Defining_Entity (Body_To_Analyze)); + Save_Global_References (Original_Body); + End_Scope; + Remove (Body_To_Analyze); - while Nkind (Unit (Comp)) = N_Subunit loop - Comp := Library_Unit (Comp); - end loop; + Expander_Mode_Restore; + Full_Analysis := Analysis_Status; - return Comp = Cunit (Main_Unit) - or else Comp = Library_Unit (Cunit (Main_Unit)); + -- Restore environment if previously saved + + if In_Instance and then Scope (Current_Scope) /= Standard_Standard then + Restore_Env; + end if; + + -- If secondary stack is used, there is no point in inlining. We have + -- already issued the warning in this case, so nothing to do. + + if Uses_Secondary_Stack (Body_To_Analyze) then + return; + end if; + + Set_Body_To_Inline (Decl, Original_Body); + Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); + Set_Is_Inlined (Spec_Id); + end Build_Body_To_Inline; + + ------------------- + -- 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; + + return; + + -- New semantics + + 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); + + -- Do not issue errors/warnings when compiling with optimizations + + elsif Optimization_Level = 0 then + + -- 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 pragma Assert (Front_End_Inlining); + Set_Is_Inlined (Subp, False); + + -- When inlining cannot take place we must issue an error. + -- For backward compatibility we still report a warning. + + if Ineffective_Inline_Warnings then + Error_Msg_NE (Msg & "p?", N, Subp); + end if; + end if; + + -- Compiling with optimizations enabled it is too early to report + -- problems since the backend may still perform inlining. In order + -- to report unhandled inlinings the program must be compiled with + -- -Winline and the error is reported by the backend. + + else + null; + end if; + end Cannot_Inline; + + -------------------------------------- + -- Can_Be_Inlined_In_GNATprove_Mode -- + -------------------------------------- + + function Can_Be_Inlined_In_GNATprove_Mode + (Spec_Id : Entity_Id; + Body_Id : Entity_Id) return Boolean + is + function Has_Some_Contract (Id : Entity_Id) return Boolean; + -- Returns True if subprogram Id has any contract (Pre, Post, Global, + -- Depends, etc.) + + function Is_Unit_Subprogram (Id : Entity_Id) return Boolean; + -- Returns True if subprogram Id defines a compilation unit + -- Shouldn't this be in Sem_Aux??? + + function In_Package_Visible_Spec (Id : Node_Id) return Boolean; + -- Returns True if subprogram Id is defined in the visible part of a + -- package specification. + + function Is_Expression_Function (Id : Entity_Id) return Boolean; + -- Returns True if subprogram Id was defined originally as an expression + -- function. + + ----------------------- + -- Has_Some_Contract -- + ----------------------- + + function Has_Some_Contract (Id : Entity_Id) return Boolean is + Items : constant Node_Id := Contract (Id); + begin + return Present (Items) + and then (Present (Pre_Post_Conditions (Items)) or else + Present (Contract_Test_Cases (Items)) or else + Present (Classifications (Items))); + end Has_Some_Contract; + + ----------------------------- + -- In_Package_Visible_Spec -- + ----------------------------- + + function In_Package_Visible_Spec (Id : Node_Id) return Boolean is + Decl : Node_Id := Parent (Parent (Id)); + P : Node_Id; + + begin + if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then + Decl := Parent (Decl); + end if; + + P := Parent (Decl); + + return Nkind (P) = N_Package_Specification + and then List_Containing (Decl) = Visible_Declarations (P); + end In_Package_Visible_Spec; + + ---------------------------- + -- Is_Expression_Function -- + ---------------------------- + + function Is_Expression_Function (Id : Entity_Id) return Boolean is + Decl : Node_Id := Parent (Parent (Id)); + begin + if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then + Decl := Parent (Decl); + end if; + + return Nkind (Original_Node (Decl)) = N_Expression_Function; + end Is_Expression_Function; + + ------------------------ + -- Is_Unit_Subprogram -- + ------------------------ + + function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is + Decl : Node_Id := Parent (Parent (Id)); + begin + if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then + Decl := Parent (Decl); + end if; + + return Nkind (Parent (Decl)) = N_Compilation_Unit; + end Is_Unit_Subprogram; + + -- Local declarations + + Id : Entity_Id; -- Procedure or function entity for the subprogram + + -- Start of Can_Be_Inlined_In_GNATprove_Mode + + begin + pragma Assert (Present (Spec_Id) or else Present (Body_Id)); + + if Present (Spec_Id) then + Id := Spec_Id; + else + Id := Body_Id; + end if; + + -- Only local subprograms without contracts are inlined in GNATprove + -- mode, as these are the subprograms which a user is not interested in + -- analyzing in isolation, but rather in the context of their call. This + -- is a convenient convention, that could be changed for an explicit + -- pragma/aspect one day. + + -- In a number of special cases, inlining is not desirable or not + -- possible, see below. + + -- Do not inline unit-level subprograms + + if Is_Unit_Subprogram (Id) then + return False; + + -- Do not inline subprograms declared in the visible part of a package + + elsif In_Package_Visible_Spec (Id) then + return False; + + -- Do not inline subprograms that have a contract on the spec or the + -- body. Use the contract(s) instead in GNATprove. + + elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id)) + or else + (Present (Body_Id) and then Has_Some_Contract (Body_Id)) + then + return False; + + -- Do not inline expression functions, which are directly inlined at the + -- prover level. + + elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id)) + or else + (Present (Body_Id) and then Is_Expression_Function (Body_Id)) + then + return False; + + -- Do not inline generic subprogram instances. The visibility rules of + -- generic instances plays badly with inlining. + + elsif Is_Generic_Instance (Spec_Id) then + return False; + + -- Only inline subprograms whose spec is marked SPARK_Mode On. For + -- the subprogram body, a similar check is performed after the body + -- is analyzed, as this is where a pragma SPARK_Mode might be inserted. + + elsif Present (Spec_Id) + and then + (No (SPARK_Pragma (Spec_Id)) + or else Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Spec_Id)) /= On) + then + return False; + + -- Subprograms in generic instances are currently not inlined, to avoid + -- problems with inlining of standard library subprograms. + + elsif Instantiation_Location (Sloc (Id)) /= No_Location then + return False; + + -- Don't inline predicate functions (treated specially by GNATprove) + + elsif Is_Predicate_Function (Id) then + return False; + + -- Otherwise, this is a subprogram declared inside the private part of a + -- package, or inside a package body, or locally in a subprogram, and it + -- does not have any contract. Inline it. + + else + return True; + end if; + end Can_Be_Inlined_In_GNATprove_Mode; + + -------------------------------------------- + -- Check_And_Split_Unconstrained_Function -- + -------------------------------------------- + + procedure Check_And_Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id) + is + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id); + -- Use generic machinery to build an unexpanded body for the subprogram. + -- This body is subsequently used for inline expansions at call sites. + + function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean; + -- Return true if we generate code for the function body N, the function + -- body N has no local declarations and its unique statement is a single + -- extended return statement with a handled statements sequence. + + procedure Generate_Subprogram_Body + (N : Node_Id; + Body_To_Inline : out Node_Id); + -- Generate a parameterless duplicate of subprogram body N. Occurrences + -- of pragmas referencing the formals are removed since they have no + -- meaning when the body is inlined and the formals are rewritten (the + -- analysis of the non-inlined body will handle these pragmas properly). + -- A new internal name is associated with Body_To_Inline. + + procedure Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id); + -- N is an inlined function body that returns an unconstrained type and + -- has a single extended return statement. Split N in two subprograms: + -- a procedure P' and a function F'. The formals of P' duplicate the + -- formals of N plus an extra formal which is used return a value; + -- its body is composed by the declarations and list of statements + -- of the extended return statement of N. + + -------------------------- + -- Build_Body_To_Inline -- + -------------------------- + + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + Original_Body : Node_Id; + Body_To_Analyze : Node_Id; + + begin + pragma Assert (Current_Scope = Spec_Id); + + -- Within an instance, the body to inline must be treated as a nested + -- generic, so that the proper global references are preserved. We + -- do not do this at the library level, because it is not needed, and + -- furthermore this causes trouble if front end inlining is activated + -- (-gnatN). + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Save_Env (Scope (Current_Scope), Scope (Current_Scope)); + end if; + + -- We need to capture references to the formals in order + -- to substitute the actuals at the point of inlining, i.e. + -- instantiation. To treat the formals as globals to the body to + -- inline, we nest it within a dummy parameterless subprogram, + -- declared within the real one. + + Generate_Subprogram_Body (N, Original_Body); + Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); + + -- Set return type of function, which is also global and does not + -- need to be resolved. + + if Ekind (Spec_Id) = E_Function then + Set_Result_Definition (Specification (Body_To_Analyze), + New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); + end if; + + if No (Declarations (N)) then + Set_Declarations (N, New_List (Body_To_Analyze)); + else + Append_To (Declarations (N), Body_To_Analyze); + end if; + + Preanalyze (Body_To_Analyze); + + Push_Scope (Defining_Entity (Body_To_Analyze)); + Save_Global_References (Original_Body); + End_Scope; + Remove (Body_To_Analyze); + + -- Restore environment if previously saved + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Restore_Env; + end if; + + pragma Assert (No (Body_To_Inline (Decl))); + Set_Body_To_Inline (Decl, Original_Body); + Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); + end Build_Body_To_Inline; + + -------------------------------------- + -- Can_Split_Unconstrained_Function -- + -------------------------------------- + + function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean + is + Ret_Node : constant Node_Id := + First (Statements (Handled_Statement_Sequence (N))); + D : Node_Id; + + begin + -- No user defined declarations allowed in the function except inside + -- the unique return statement; implicit labels are the only allowed + -- declarations. + + if not Is_Empty_List (Declarations (N)) then + D := First (Declarations (N)); + while Present (D) loop + if Nkind (D) /= N_Implicit_Label_Declaration then + return False; + end if; + + Next (D); + end loop; + end if; + + -- We only split the inlined function when we are generating the code + -- of its body; otherwise we leave duplicated split subprograms in + -- the tree which (if referenced) generate wrong references at link + -- time. + + return In_Extended_Main_Code_Unit (N) + and then Present (Ret_Node) + and then Nkind (Ret_Node) = N_Extended_Return_Statement + and then No (Next (Ret_Node)) + and then Present (Handled_Statement_Sequence (Ret_Node)); + end Can_Split_Unconstrained_Function; + + ----------------------------- + -- Generate_Body_To_Inline -- + ----------------------------- + + procedure Generate_Subprogram_Body + (N : Node_Id; + Body_To_Inline : out Node_Id) + is + begin + -- Within an instance, the body to inline must be treated as a nested + -- generic, so that the proper global references are preserved. + + -- Note that we do not do this at the library level, because it + -- is not needed, and furthermore this causes trouble if front + -- end inlining is activated (-gnatN). + + if In_Instance + and then Scope (Current_Scope) /= Standard_Standard + then + Body_To_Inline := Copy_Generic_Node (N, Empty, True); + else + Body_To_Inline := Copy_Separate_Tree (N); + end if; + + -- A pragma Unreferenced or pragma Unmodified that mentions a formal + -- parameter has no meaning when the body is inlined and the formals + -- are rewritten. Remove it from body to inline. The analysis of the + -- non-inlined body will handle the pragma properly. + + Remove_Pragmas (Body_To_Inline); + + -- We need to capture references to the formals in order + -- to substitute the actuals at the point of inlining, i.e. + -- instantiation. To treat the formals as globals to the body to + -- inline, we nest it within a dummy parameterless subprogram, + -- declared within the real one. + + Set_Parameter_Specifications + (Specification (Body_To_Inline), No_List); + + -- A new internal name is associated with Body_To_Inline to avoid + -- conflicts when the non-inlined body N is analyzed. + + Set_Defining_Unit_Name (Specification (Body_To_Inline), + Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); + Set_Corresponding_Spec (Body_To_Inline, Empty); + end Generate_Subprogram_Body; + + ---------------------------------- + -- Split_Unconstrained_Function -- + ---------------------------------- + + procedure Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Ret_Node : constant Node_Id := + First (Statements (Handled_Statement_Sequence (N))); + Ret_Obj : constant Node_Id := + First (Return_Object_Declarations (Ret_Node)); + + procedure Build_Procedure + (Proc_Id : out Entity_Id; + Decl_List : out List_Id); + -- Build a procedure containing the statements found in the extended + -- return statement of the unconstrained function body N. + + --------------------- + -- Build_Procedure -- + --------------------- + + procedure Build_Procedure + (Proc_Id : out Entity_Id; + Decl_List : out List_Id) + is + Formal : Entity_Id; + Formal_List : constant List_Id := New_List; + Proc_Spec : Node_Id; + Proc_Body : Node_Id; + Subp_Name : constant Name_Id := New_Internal_Name ('F'); + Body_Decl_List : List_Id := No_List; + Param_Type : Node_Id; + + begin + if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then + Param_Type := + New_Copy (Object_Definition (Ret_Obj)); + else + Param_Type := + New_Copy (Subtype_Mark (Object_Definition (Ret_Obj))); + end if; + + Append_To (Formal_List, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Ret_Obj))), + In_Present => False, + Out_Present => True, + Null_Exclusion_Present => False, + Parameter_Type => Param_Type)); + + Formal := First_Formal (Spec_Id); + while Present (Formal) loop + Append_To (Formal_List, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Sloc (Formal), + Chars => Chars (Formal)), + In_Present => In_Present (Parent (Formal)), + Out_Present => Out_Present (Parent (Formal)), + Null_Exclusion_Present => + Null_Exclusion_Present (Parent (Formal)), + Parameter_Type => + New_Occurrence_Of (Etype (Formal), Loc), + Expression => + Copy_Separate_Tree (Expression (Parent (Formal))))); + + Next_Formal (Formal); + end loop; + + Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name); + + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc_Id, + Parameter_Specifications => Formal_List); + + Decl_List := New_List; + + Append_To (Decl_List, + Make_Subprogram_Declaration (Loc, Proc_Spec)); + + -- Can_Convert_Unconstrained_Function checked that the function + -- has no local declarations except implicit label declarations. + -- Copy these declarations to the built procedure. + + if Present (Declarations (N)) then + Body_Decl_List := New_List; + + declare + D : Node_Id; + New_D : Node_Id; + + begin + D := First (Declarations (N)); + while Present (D) loop + pragma Assert (Nkind (D) = N_Implicit_Label_Declaration); + + New_D := + Make_Implicit_Label_Declaration (Loc, + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (D))), + Label_Construct => Empty); + Append_To (Body_Decl_List, New_D); + + Next (D); + end loop; + end; + end if; + + pragma Assert (Present (Handled_Statement_Sequence (Ret_Node))); + + Proc_Body := + Make_Subprogram_Body (Loc, + Specification => Copy_Separate_Tree (Proc_Spec), + Declarations => Body_Decl_List, + Handled_Statement_Sequence => + Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node))); + + Set_Defining_Unit_Name (Specification (Proc_Body), + Make_Defining_Identifier (Loc, Subp_Name)); + + Append_To (Decl_List, Proc_Body); + end Build_Procedure; + + -- Local variables + + New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj); + Blk_Stmt : Node_Id; + Proc_Id : Entity_Id; + Proc_Call : Node_Id; + + -- Start of processing for Split_Unconstrained_Function + + begin + -- Build the associated procedure, analyze it and insert it before + -- the function body N. + + declare + Scope : constant Entity_Id := Current_Scope; + Decl_List : List_Id; + begin + Pop_Scope; + Build_Procedure (Proc_Id, Decl_List); + Insert_Actions (N, Decl_List); + Push_Scope (Scope); + end; + + -- Build the call to the generated procedure + + declare + Actual_List : constant List_Id := New_List; + Formal : Entity_Id; + + begin + Append_To (Actual_List, + New_Occurrence_Of (Defining_Identifier (New_Obj), Loc)); + + Formal := First_Formal (Spec_Id); + while Present (Formal) loop + Append_To (Actual_List, New_Occurrence_Of (Formal, Loc)); + + -- Avoid spurious warning on unreferenced formals + + Set_Referenced (Formal); + Next_Formal (Formal); + end loop; + + Proc_Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Proc_Id, Loc), + Parameter_Associations => Actual_List); + end; + + -- Generate + + -- declare + -- New_Obj : ... + -- begin + -- main_1__F1b (New_Obj, ...); + -- return Obj; + -- end B10b; + + Blk_Stmt := + Make_Block_Statement (Loc, + Declarations => New_List (New_Obj), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + + Proc_Call, + + Make_Simple_Return_Statement (Loc, + Expression => + New_Occurrence_Of + (Defining_Identifier (New_Obj), Loc))))); + + Rewrite (Ret_Node, Blk_Stmt); + end Split_Unconstrained_Function; + + -- Local variables + + Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); + + -- Start of processing for Check_And_Split_Unconstrained_Function + + begin + pragma Assert (Back_End_Inlining + and then Ekind (Spec_Id) = E_Function + and then Returns_Unconstrained_Type (Spec_Id) + and then Comes_From_Source (Body_Id) + and then (Has_Pragma_Inline_Always (Spec_Id) + or else Optimization_Level > 0)); + + -- This routine must not be used in GNATprove mode since GNATprove + -- relies on frontend inlining + + pragma Assert (not GNATprove_Mode); + + -- No need to split the function if we cannot generate the code + + if Serious_Errors_Detected /= 0 then + return; + end if; + + -- Do not inline any subprogram that contains nested subprograms, + -- since the backend inlining circuit seems to generate uninitialized + -- references in this case. We know this happens in the case of front + -- end ZCX support, but it also appears it can happen in other cases + -- as well. The backend often rejects attempts to inline in the case + -- of nested procedures anyway, so little if anything is lost by this. + -- Note that this is test is for the benefit of the back-end. There + -- is a separate test for front-end inlining that also rejects nested + -- subprograms. + + -- Do not do this test if errors have been detected, because in some + -- error cases, this code blows up, and we don't need it anyway if + -- there have been errors, since we won't get to the linker anyway. + + declare + P_Ent : Node_Id; + + begin + P_Ent := Body_Id; + loop + P_Ent := Scope (P_Ent); + exit when No (P_Ent) or else P_Ent = Standard_Standard; + + if Is_Subprogram (P_Ent) then + Set_Is_Inlined (P_Ent, False); + + if Comes_From_Source (P_Ent) + and then (Has_Pragma_Inline (P_Ent)) + then + Cannot_Inline + ("cannot inline& (nested subprogram)?", N, P_Ent, + Is_Serious => True); + return; + end if; + end if; + end loop; + end; + + -- No action needed in stubs since the attribute Body_To_Inline + -- is not available + + if Nkind (Decl) = N_Subprogram_Body_Stub then + return; + + -- Cannot build the body to inline if the attribute is already set. + -- This attribute may have been set if this is a subprogram renaming + -- declarations (see Freeze.Build_Renamed_Body). + + elsif Present (Body_To_Inline (Decl)) then + return; + + -- Check excluded declarations + + elsif Present (Declarations (N)) + and then Has_Excluded_Declaration (Spec_Id, Declarations (N)) + then + return; + + -- Check excluded statements. There is no need to protect us against + -- exception handlers since they are supported by the GCC backend. + + elsif Present (Handled_Statement_Sequence (N)) + and then Has_Excluded_Statement + (Spec_Id, Statements (Handled_Statement_Sequence (N))) + then + return; + end if; + + -- Build the body to inline only if really needed + + if Can_Split_Unconstrained_Function (N) then + Split_Unconstrained_Function (N, Spec_Id); + Build_Body_To_Inline (N, Spec_Id); + Set_Is_Inlined (Spec_Id); + end if; + end Check_And_Split_Unconstrained_Function; + + ------------------------------------- + -- Check_Package_Body_For_Inlining -- + ------------------------------------- + + procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is + Bname : Unit_Name_Type; + E : Entity_Id; + OK : Boolean; + + begin + if Is_Compilation_Unit (P) + and then not Is_Generic_Instance (P) + then + Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); + + E := First_Entity (P); + while Present (E) loop + if Has_Pragma_Inline_Always (E) + or else (Front_End_Inlining and then Has_Pragma_Inline (E)) + then + if not Is_Loaded (Bname) then + Load_Needed_Body (N, OK); + + if OK then + + -- Check we are not trying to inline a parent whose body + -- depends on a child, when we are compiling the body of + -- the child. Otherwise we have a potential elaboration + -- circularity with inlined subprograms and with + -- Taft-Amendment types. + + declare + Comp : Node_Id; -- Body just compiled + Child_Spec : Entity_Id; -- Spec of main unit + Ent : Entity_Id; -- For iteration + With_Clause : Node_Id; -- Context of body. + + begin + if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body + and then Present (Body_Entity (P)) + then + Child_Spec := + Defining_Entity + ((Unit (Library_Unit (Cunit (Main_Unit))))); + + Comp := + Parent (Unit_Declaration_Node (Body_Entity (P))); + + -- Check whether the context of the body just + -- compiled includes a child of itself, and that + -- child is the spec of the main compilation. + + With_Clause := First (Context_Items (Comp)); + while Present (With_Clause) loop + if Nkind (With_Clause) = N_With_Clause + and then + Scope (Entity (Name (With_Clause))) = P + and then + Entity (Name (With_Clause)) = Child_Spec + then + Error_Msg_Node_2 := Child_Spec; + Error_Msg_NE + ("body of & depends on child unit&??", + With_Clause, P); + Error_Msg_N + ("\subprograms in body cannot be inlined??", + With_Clause); + + -- Disable further inlining from this unit, + -- and keep Taft-amendment types incomplete. + + Ent := First_Entity (P); + while Present (Ent) loop + if Is_Type (Ent) + and then Has_Completion_In_Body (Ent) + then + Set_Full_View (Ent, Empty); + + elsif Is_Subprogram (Ent) then + Set_Is_Inlined (Ent, False); + end if; + + Next_Entity (Ent); + end loop; + + return; + end if; + + Next (With_Clause); + end loop; + end if; + end; + + elsif Ineffective_Inline_Warnings then + Error_Msg_Unit_1 := Bname; + Error_Msg_N + ("unable to inline subprograms defined in $??", P); + Error_Msg_N ("\body not found??", P); + return; + end if; + end if; + + return; + end if; + + Next_Entity (E); + end loop; + end if; + end Check_Package_Body_For_Inlining; + + -------------------- + -- Cleanup_Scopes -- + -------------------- + + procedure Cleanup_Scopes is + Elmt : Elmt_Id; + Decl : Node_Id; + Scop : Entity_Id; + + begin + Elmt := First_Elmt (To_Clean); + while Present (Elmt) loop + Scop := Node (Elmt); + + if Ekind (Scop) = E_Entry then + Scop := Protected_Body_Subprogram (Scop); + + elsif Is_Subprogram (Scop) + and then Is_Protected_Type (Scope (Scop)) + and then Present (Protected_Body_Subprogram (Scop)) + then + -- If a protected operation contains an instance, its cleanup + -- operations have been delayed, and the subprogram has been + -- rewritten in the expansion of the enclosing protected body. It + -- is the corresponding subprogram that may require the cleanup + -- operations, so propagate the information that triggers cleanup + -- activity. + + Set_Uses_Sec_Stack + (Protected_Body_Subprogram (Scop), + Uses_Sec_Stack (Scop)); + + Scop := Protected_Body_Subprogram (Scop); + end if; + + if Ekind (Scop) = E_Block then + Decl := Parent (Block_Node (Scop)); + + else + Decl := Unit_Declaration_Node (Scop); + + if Nkind_In (Decl, N_Subprogram_Declaration, + N_Task_Type_Declaration, + N_Subprogram_Body_Stub) + then + Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); + end if; + end if; + + Push_Scope (Scop); + Expand_Cleanup_Actions (Decl); + End_Scope; + + Elmt := Next_Elmt (Elmt); + end loop; + end Cleanup_Scopes; + + ------------------------- + -- Expand_Inlined_Call -- + ------------------------- + + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); + Is_Predef : constant Boolean := + Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Subp))); + Orig_Bod : constant Node_Id := + Body_To_Inline (Unit_Declaration_Node (Subp)); + + Blk : Node_Id; + Decl : Node_Id; + Decls : constant List_Id := New_List; + Exit_Lab : Entity_Id := Empty; + F : Entity_Id; + A : Node_Id; + Lab_Decl : Node_Id; + Lab_Id : Node_Id; + New_A : Node_Id; + Num_Ret : Int := 0; + Ret_Type : Entity_Id; + + Targ : Node_Id; + -- The target of the call. If context is an assignment statement then + -- this is the left-hand side of the assignment, else it is a temporary + -- to which the return value is assigned prior to rewriting the call. + + Targ1 : Node_Id; + -- A separate target used when the return type is unconstrained + + Temp : Entity_Id; + Temp_Typ : Entity_Id; + + Return_Object : Entity_Id := Empty; + -- Entity in declaration in an extended_return_statement + + Is_Unc : Boolean; + Is_Unc_Decl : Boolean; + -- If the type returned by the function is unconstrained and the call + -- can be inlined, special processing is required. + + 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 + -- declaration). Does nothing if Exit_Lab already set. + + function Process_Formals (N : Node_Id) return Traverse_Result; + -- Replace occurrence of a formal with the corresponding actual, or the + -- thunk generated for it. Replace a return statement with an assignment + -- to the target of the call, with appropriate conversions if needed. + + function Process_Sloc (Nod : Node_Id) return Traverse_Result; + -- If the call being expanded is that of an internal subprogram, set the + -- sloc of the generated block to that of the call itself, so that the + -- expansion is skipped by the "next" command in gdb. Same processing + -- for a subprogram in a predefined file, e.g. Ada.Tags. If + -- Debug_Generated_Code is true, suppress this change to simplify our + -- own development. Same in GNATprove mode, to ensure that warnings and + -- diagnostics point to the proper location. + + procedure Reset_Dispatching_Calls (N : Node_Id); + -- In subtree N search for occurrences of dispatching calls that use the + -- Ada 2005 Object.Operation notation and the object is a formal of the + -- inlined subprogram. Reset the entity associated with Operation in all + -- the found occurrences. + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); + -- If the function body is a single expression, replace call with + -- expression, else insert block appropriately. + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); + -- If procedure body has no local variables, inline body without + -- creating block, otherwise rewrite call with block. + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; + -- Determine whether a formal parameter is used only once in Orig_Bod + + --------------------- + -- Make_Exit_Label -- + --------------------- + + procedure Make_Exit_Label is + Lab_Ent : Entity_Id; + begin + if No (Exit_Lab) then + Lab_Ent := Make_Temporary (Loc, 'L'); + Lab_Id := New_Occurrence_Of (Lab_Ent, Loc); + Exit_Lab := Make_Label (Loc, Lab_Id); + Lab_Decl := + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Lab_Ent, + Label_Construct => Exit_Lab); + end if; + end Make_Exit_Label; + + --------------------- + -- Process_Formals -- + --------------------- + + function Process_Formals (N : Node_Id) return Traverse_Result is + A : Entity_Id; + E : Entity_Id; + Ret : Node_Id; + + begin + if Is_Entity_Name (N) and then Present (Entity (N)) then + E := Entity (N); + + if Is_Formal (E) and then Scope (E) = Subp then + A := Renamed_Object (E); + + -- Rewrite the occurrence of the formal into an occurrence of + -- the actual. Also establish visibility on the proper view of + -- the actual's subtype for the body's context (if the actual's + -- subtype is private at the call point but its full view is + -- visible to the body, then the inlined tree here must be + -- analyzed with the full view). + + if Is_Entity_Name (A) then + Rewrite (N, New_Occurrence_Of (Entity (A), Loc)); + Check_Private_View (N); + + elsif Nkind (A) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (A, Loc)); + Check_Private_View (N); + + -- Numeric literal + + else + Rewrite (N, New_Copy (A)); + end if; + end if; + + return Skip; + + elsif Is_Entity_Name (N) + and then Present (Return_Object) + and then Chars (N) = Chars (Return_Object) + then + -- Occurrence within an extended return statement. The return + -- object is local to the body been inlined, and thus the generic + -- copy is not analyzed yet, so we match by name, and replace it + -- with target of call. + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, New_Occurrence_Of (Targ, Loc)); + else + Rewrite (N, New_Copy_Tree (Targ)); + end if; + + return Skip; + + elsif Nkind (N) = N_Simple_Return_Statement then + if No (Expression (N)) then + Make_Exit_Label; + Rewrite (N, + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); + + else + if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Parent (N))) = N_Subprogram_Body + then + -- Function body is a single expression. No need for + -- exit label. + + null; + + else + Num_Ret := Num_Ret + 1; + Make_Exit_Label; + end if; + + -- Because of the presence of private types, the views of the + -- expression and the context may be different, so place an + -- unchecked conversion to the context type to avoid spurious + -- 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. + + if Nkind_In (Expression (N), N_Aggregate, + N_Null, + N_Real_Literal, + N_Integer_Literal) + then + Ret := + Make_Qualified_Expression (Sloc (N), + Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), + Expression => Relocate_Node (Expression (N))); + else + Ret := + Unchecked_Convert_To + (Ret_Type, Relocate_Node (Expression (N))); + end if; + + if Nkind (Targ) = N_Defining_Identifier then + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Ret)); + else + Rewrite (N, + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Ret)); + end if; + + Set_Assignment_OK (Name (N)); + + if Present (Exit_Lab) then + Insert_After (N, + Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); + end if; + end if; + + return OK; + + -- An extended return becomes a block whose first statement is the + -- assignment of the initial expression of the return object to the + -- target of the call itself. + + elsif Nkind (N) = N_Extended_Return_Statement then + declare + Return_Decl : constant Entity_Id := + First (Return_Object_Declarations (N)); + Assign : Node_Id; + + begin + Return_Object := Defining_Identifier (Return_Decl); + + if Present (Expression (Return_Decl)) then + if Nkind (Targ) = N_Defining_Identifier then + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Targ, Loc), + Expression => Expression (Return_Decl)); + else + Assign := + Make_Assignment_Statement (Loc, + Name => New_Copy (Targ), + Expression => Expression (Return_Decl)); + end if; + + Set_Assignment_OK (Name (Assign)); + + if No (Handled_Statement_Sequence (N)) then + Set_Handled_Statement_Sequence (N, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List)); + end if; + + Prepend (Assign, + Statements (Handled_Statement_Sequence (N))); + end if; + + Rewrite (N, + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Handled_Statement_Sequence (N))); + + return OK; + end; + + -- Remove pragma Unreferenced since it may refer to formals that + -- are not visible in the inlined body, and in any case we will + -- not be posting warnings on the inlined body so it is unneeded. + + elsif Nkind (N) = N_Pragma + and then Pragma_Name (N) = Name_Unreferenced + then + Rewrite (N, Make_Null_Statement (Sloc (N))); + return OK; + + else + return OK; + end if; + end Process_Formals; + + procedure Replace_Formals is new Traverse_Proc (Process_Formals); + + ------------------ + -- Process_Sloc -- + ------------------ + + function Process_Sloc (Nod : Node_Id) return Traverse_Result is + begin + if not Debug_Generated_Code then + Set_Sloc (Nod, Sloc (N)); + Set_Comes_From_Source (Nod, False); + end if; + + return OK; + end Process_Sloc; + + procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); + + ------------------------------ + -- Reset_Dispatching_Calls -- + ------------------------------ + + procedure Reset_Dispatching_Calls (N : Node_Id) is + + function Do_Reset (N : Node_Id) return Traverse_Result; + -- Comment required ??? + + -------------- + -- Do_Reset -- + -------------- + + function Do_Reset (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Procedure_Call_Statement + and then Nkind (Name (N)) = N_Selected_Component + and then Nkind (Prefix (Name (N))) = N_Identifier + and then Is_Formal (Entity (Prefix (Name (N)))) + and then Is_Dispatching_Operation + (Entity (Selector_Name (Name (N)))) + then + Set_Entity (Selector_Name (Name (N)), Empty); + end if; + + return OK; + end Do_Reset; + + function Do_Reset_Calls is new Traverse_Func (Do_Reset); + + -- Local variables + + Dummy : constant Traverse_Result := Do_Reset_Calls (N); + pragma Unreferenced (Dummy); + + -- Start of processing for Reset_Dispatching_Calls + + begin + null; + end Reset_Dispatching_Calls; + + --------------------------- + -- Rewrite_Function_Call -- + --------------------------- + + procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + Fst : constant Node_Id := First (Statements (HSS)); + + begin + -- Optimize simple case: function body is a single return statement, + -- which has been expanded into an assignment. + + if Is_Empty_List (Declarations (Blk)) + and then Nkind (Fst) = N_Assignment_Statement + and then No (Next (Fst)) + then + -- The function call may have been rewritten as the temporary + -- that holds the result of the call, in which case remove the + -- now useless declaration. + + if Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); + end if; + + Rewrite (N, Expression (Fst)); + + elsif Nkind (N) = N_Identifier + and then Nkind (Parent (Entity (N))) = N_Object_Declaration + then + -- The block assigns the result of the call to the temporary + + Insert_After (Parent (Entity (N)), Blk); + + -- If the context is an assignment, and the left-hand side is free of + -- side-effects, the replacement is also safe. + -- Can this be generalized further??? + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then + (Is_Entity_Name (Name (Parent (N))) + or else + (Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N))))) + + or else + (Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Entity_Name (Prefix (Name (Parent (N)))))) + then + -- Replace assignment with the block + + declare + Original_Assignment : constant Node_Id := Parent (N); + + begin + -- Preserve the original assignment node to keep the complete + -- assignment subtree consistent enough for Analyze_Assignment + -- to proceed (specifically, the original Lhs node must still + -- have an assignment statement as its parent). + + -- We cannot rely on Original_Node to go back from the block + -- node to the assignment node, because the assignment might + -- already be a rewrite substitution. + + Discard_Node (Relocate_Node (Original_Assignment)); + Rewrite (Original_Assignment, Blk); + end; + + elsif Nkind (Parent (N)) = N_Object_Declaration then + + -- A call to a function which returns an unconstrained type + -- found in the expression initializing an object-declaration is + -- expanded into a procedure call which must be added after the + -- object declaration. + + if Is_Unc_Decl and Back_End_Inlining then + Insert_Action_After (Parent (N), Blk); + else + Set_Expression (Parent (N), Empty); + Insert_After (Parent (N), Blk); + end if; + + elsif Is_Unc and then not Back_End_Inlining then + Insert_Before (Parent (N), Blk); + end if; + end Rewrite_Function_Call; + + ---------------------------- + -- Rewrite_Procedure_Call -- + ---------------------------- + + procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is + HSS : constant Node_Id := Handled_Statement_Sequence (Blk); + + begin + -- If there is a transient scope for N, this will be the scope of the + -- actions for N, and the statements in Blk need to be within this + -- scope. For example, they need to have visibility on the constant + -- declarations created for the formals. + + -- If N needs no transient scope, and if there are no declarations in + -- the inlined body, we can do a little optimization and insert the + -- statements for the body directly after N, and rewrite N to a + -- null statement, instead of rewriting N into a full-blown block + -- statement. + + if not Scope_Is_Transient + and then Is_Empty_List (Declarations (Blk)) + then + Insert_List_After (N, Statements (HSS)); + Rewrite (N, Make_Null_Statement (Loc)); + else + Rewrite (N, Blk); + end if; + end Rewrite_Procedure_Call; + + ------------------------- + -- Formal_Is_Used_Once -- + ------------------------- + + function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is + Use_Counter : Int := 0; + + function Count_Uses (N : Node_Id) return Traverse_Result; + -- Traverse the tree and count the uses of the formal parameter. + -- In this case, for optimization purposes, we do not need to + -- continue the traversal once more than one use is encountered. + + ---------------- + -- Count_Uses -- + ---------------- + + function Count_Uses (N : Node_Id) return Traverse_Result is + begin + -- The original node is an identifier + + if Nkind (N) = N_Identifier + and then Present (Entity (N)) + + -- Original node's entity points to the one in the copied body + + and then Nkind (Entity (N)) = N_Identifier + and then Present (Entity (Entity (N))) + + -- The entity of the copied node is the formal parameter + + and then Entity (Entity (N)) = Formal + then + Use_Counter := Use_Counter + 1; + + if Use_Counter > 1 then + + -- Denote more than one use and abandon the traversal + + Use_Counter := 2; + return Abandon; + + end if; + end if; + + return OK; + end Count_Uses; + + procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); + + -- Start of processing for Formal_Is_Used_Once + + begin + Count_Formal_Uses (Orig_Bod); + return Use_Counter = 1; + end Formal_Is_Used_Once; + + -- Start of processing for Expand_Inlined_Call + + begin + -- Initializations for old/new semantics + + if not Back_End_Inlining then + Is_Unc := Is_Array_Type (Etype (Subp)) + and then not Is_Constrained (Etype (Subp)); + Is_Unc_Decl := False; + else + Is_Unc := Returns_Unconstrained_Type (Subp) + and then Optimization_Level > 0; + Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration + and then Is_Unc; + end if; + + -- Check for an illegal attempt to inline a recursive procedure. If the + -- subprogram has parameters this is detected when trying to supply a + -- binding for parameters that already have one. For parameterless + -- subprograms this must be done explicitly. + + if In_Open_Scopes (Subp) then + Error_Msg_N ("call to recursive subprogram cannot be inlined??", N); + 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 + -- Body_To_Inline is also set for renamings (see sinfo.ads) + + elsif Nkind (Orig_Bod) in N_Entity then + return; + + -- Skip inlining if the function returns an unconstrained type using + -- an extended return statement since this part of the new inlining + -- model which is not yet supported by the current implementation. ??? + + elsif Is_Unc + and then + Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) + = N_Extended_Return_Statement + and then not Back_End_Inlining + then + return; + end if; + + if Nkind (Orig_Bod) = N_Defining_Identifier + or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol + then + -- Subprogram is renaming_as_body. Calls occurring after the renaming + -- can be replaced with calls to the renamed entity directly, because + -- the subprograms are subtype conformant. If the renamed subprogram + -- is an inherited operation, we must redo the expansion because + -- implicit conversions may be needed. Similarly, if the renamed + -- entity is inlined, expand the call for further optimizations. + + Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); + + if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then + Expand_Call (N); + end if; + + return; + end if; + + -- Register the call in the list of inlined calls + + Append_New_Elmt (N, To => Inlined_Calls); + + -- Use generic machinery to copy body of inlined subprogram, as if it + -- were an instantiation, resetting source locations appropriately, so + -- that nested inlined calls appear in the main unit. + + Save_Env (Subp, Empty); + Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); + + -- Old semantics + + if not Back_End_Inlining then + declare + Bod : Node_Id; + + begin + Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); + Blk := + Make_Block_Statement (Loc, + Declarations => Declarations (Bod), + Handled_Statement_Sequence => + Handled_Statement_Sequence (Bod)); + + if No (Declarations (Bod)) then + Set_Declarations (Blk, New_List); + 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 + -- on local variables. Otherwise there is no way to declare the + -- result outside of the block. Needless to say, in general the + -- bounds will depend on the actuals in the call. + + -- If the context is an assignment statement, as is the case + -- for the expansion of an extended return, the left-hand side + -- provides bounds even if the return type is unconstrained. + + if Is_Unc then + declare + First_Decl : Node_Id; + + begin + First_Decl := First (Declarations (Blk)); + + if Nkind (First_Decl) /= N_Object_Declaration then + return; + end if; + + if Nkind (Parent (N)) /= N_Assignment_Statement then + Targ1 := Defining_Identifier (First_Decl); + else + Targ1 := Name (Parent (N)); + end if; + end; + end if; + end; + + -- New semantics + + else + declare + Bod : Node_Id; + + begin + -- General case + + if not Is_Unc then + Bod := + Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); + Blk := + Make_Block_Statement (Loc, + Declarations => Declarations (Bod), + Handled_Statement_Sequence => + Handled_Statement_Sequence (Bod)); + + -- Inline a call to a function that returns an unconstrained type. + -- The semantic analyzer checked that frontend-inlined functions + -- returning unconstrained types have no declarations and have + -- a single extended return statement. As part of its processing + -- the function was split in two subprograms: a procedure P and + -- a function F that has a block with a call to procedure P (see + -- Split_Unconstrained_Function). + + else + pragma Assert + (Nkind + (First + (Statements (Handled_Statement_Sequence (Orig_Bod)))) = + N_Block_Statement); + + declare + Blk_Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (Orig_Bod))); + First_Stmt : constant Node_Id := + First (Statements (Handled_Statement_Sequence (Blk_Stmt))); + Second_Stmt : constant Node_Id := Next (First_Stmt); + + begin + pragma Assert + (Nkind (First_Stmt) = N_Procedure_Call_Statement + and then Nkind (Second_Stmt) = N_Simple_Return_Statement + and then No (Next (Second_Stmt))); + + Bod := + Copy_Generic_Node + (First + (Statements (Handled_Statement_Sequence (Orig_Bod))), + Empty, Instantiating => True); + Blk := Bod; + + -- 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 on local variables. + -- Otherwise there is no way to declare the result outside + -- of the block. Needless to say, in general the bounds will + -- depend on the actuals in the call. + + if Nkind (Parent (N)) /= N_Assignment_Statement then + Targ1 := Defining_Identifier (First (Declarations (Blk))); + + -- If the context is an assignment statement, as is the case + -- for the expansion of an extended return, the left-hand + -- side provides bounds even if the return type is + -- unconstrained. + + else + Targ1 := Name (Parent (N)); + end if; + end; + end if; + + if No (Declarations (Bod)) then + Set_Declarations (Blk, New_List); + end if; + end; + end if; + + -- If this is a derived function, establish the proper return type + + if Present (Orig_Subp) and then Orig_Subp /= Subp then + Ret_Type := Etype (Orig_Subp); + else + Ret_Type := Etype (Subp); + end if; + + -- Create temporaries for the actuals that are expressions, or that are + -- scalars and require copying to preserve semantics. + + F := First_Formal (Subp); + A := First_Actual (N); + while Present (F) loop + if Present (Renamed_Object (F)) then + + -- If expander is active, it is an error to try to inline a + -- recursive program. In GNATprove mode, just indicate that the + -- inlining will not happen, and mark the subprogram as not always + -- inlined. + + if GNATprove_Mode then + Cannot_Inline + ("cannot inline call to recursive subprogram?", N, Subp); + Set_Is_Inlined_Always (Subp, False); + else + Error_Msg_N + ("cannot inline call to recursive subprogram", N); + end if; + + return; + end if; + + -- Reset Last_Assignment for any parameters of mode out or in out, to + -- prevent spurious warnings about overwriting for assignments to the + -- formal in the inlined code. + + if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then + Set_Last_Assignment (Entity (A), Empty); + end if; + + -- If the argument may be a controlling argument in a call within + -- the inlined body, we must preserve its classwide nature to insure + -- that dynamic dispatching take place subsequently. If the formal + -- has a constraint it must be preserved to retain the semantics of + -- the body. + + if Is_Class_Wide_Type (Etype (F)) + or else (Is_Access_Type (Etype (F)) + and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) + then + Temp_Typ := Etype (F); + + elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) + and then Etype (F) /= Base_Type (Etype (F)) + then + Temp_Typ := Etype (F); + else + Temp_Typ := Etype (A); + end if; + + -- If the actual is a simple name or a literal, no need to + -- create a temporary, object can be used directly. + + -- 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. + + if (Is_Entity_Name (A) + and then + (not Is_Scalar_Type (Etype (A)) + or else Ekind (Entity (A)) = E_Enumeration_Literal)) + + -- 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. + + or else (Nkind (A) = N_Identifier + and then Formal_Is_Used_Once (F)) + + or else + (Nkind_In (A, N_Real_Literal, + N_Integer_Literal, + N_Character_Literal) + and then not Address_Taken (F)) + then + if Etype (F) /= Etype (A) then + Set_Renamed_Object + (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); + else + Set_Renamed_Object (F, A); + end if; + + else + Temp := Make_Temporary (Loc, 'C'); + + -- If the actual for an in/in-out parameter is a view conversion, + -- make it into an unchecked conversion, given that an untagged + -- type conversion is not a proper object for a renaming. + + -- In-out conversions that involve real conversions have already + -- been transformed in Expand_Actuals. + + if Nkind (A) = N_Type_Conversion + and then Ekind (F) /= E_In_Parameter + then + New_A := + Make_Unchecked_Type_Conversion (Loc, + 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)); + Temp_Typ := Etype (F); + + else + New_A := Relocate_Node (A); + end if; + + Set_Sloc (New_A, Sloc (N)); + + -- If the actual has a by-reference type, it cannot be copied, + -- so its value is captured in a renaming declaration. Otherwise + -- declare a local constant initialized with the actual. + + -- We also use a renaming declaration for expressions of an array + -- type that is not bit-packed, both for efficiency reasons and to + -- respect the semantics of the call: in most cases the original + -- call will pass the parameter by reference, and thus the inlined + -- code will have the same semantics. + + -- Finally, we need a renaming declaration in the case of limited + -- types for which initialization cannot be by copy either. + + if Ekind (F) = E_In_Parameter + and then not Is_By_Reference_Type (Etype (A)) + and then not Is_Limited_Type (Etype (A)) + and then + (not Is_Array_Type (Etype (A)) + or else not Is_Object_Reference (A) + or else Is_Bit_Packed_Array (Etype (A))) + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), + Expression => New_A); + else + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Temp, + Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), + Name => New_A); + end if; + + Append (Decl, Decls); + Set_Renamed_Object (F, Temp); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + -- Establish target of function call. If context is not assignment or + -- declaration, create a temporary as a target. The declaration for the + -- temporary may be subsequently optimized away if the body is a single + -- expression, or if the left-hand side of the assignment is simple + -- enough, i.e. an entity or an explicit dereference of one. + + if Ekind (Subp) = E_Function then + if Nkind (Parent (N)) = N_Assignment_Statement + and then Is_Entity_Name (Name (Parent (N))) + then + Targ := Name (Parent (N)); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Explicit_Dereference + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := Name (Parent (N)); + + elsif Nkind (Parent (N)) = N_Assignment_Statement + and then Nkind (Name (Parent (N))) = N_Selected_Component + and then Is_Entity_Name (Prefix (Name (Parent (N)))) + then + Targ := New_Copy_Tree (Name (Parent (N))); + + elsif Nkind (Parent (N)) = N_Object_Declaration + and then Is_Limited_Type (Etype (Subp)) + then + Targ := Defining_Identifier (Parent (N)); + + -- New semantics: In an object declaration avoid an extra copy + -- of the result of a call to an inlined function that returns + -- an unconstrained type + + elsif Back_End_Inlining + and then Nkind (Parent (N)) = N_Object_Declaration + and then Is_Unc + then + Targ := Defining_Identifier (Parent (N)); + + else + -- Replace call with temporary and create its declaration + + Temp := Make_Temporary (Loc, 'C'); + Set_Is_Internal (Temp); + + -- For the unconstrained case, the generated temporary has the + -- same constrained declaration as the result variable. It may + -- eventually be possible to remove that temporary and use the + -- result variable directly. + + if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement + then + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + + Replace_Formals (Decl); + + else + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); + + Set_Etype (Temp, Ret_Type); + end if; + + Set_No_Initialization (Decl); + Append (Decl, Decls); + Rewrite (N, New_Occurrence_Of (Temp, Loc)); + Targ := Temp; + end if; + end if; + + Insert_Actions (N, Decls); + + if Is_Unc_Decl then + + -- Special management for inlining a call to a function that returns + -- an unconstrained type and initializes an object declaration: we + -- avoid generating undesired extra calls and goto statements. + + -- Given: + -- function Func (...) return ... + -- begin + -- declare + -- Result : String (1 .. 4); + -- begin + -- Proc (Result, ...); + -- return Result; + -- end; + -- end F; + + -- Result : String := Func (...); + + -- Replace this object declaration by: + + -- Result : String (1 .. 4); + -- Proc (Result, ...); + + Remove_Homonym (Targ); + + Decl := + Make_Object_Declaration + (Loc, + Defining_Identifier => Targ, + Object_Definition => + New_Copy_Tree (Object_Definition (Parent (Targ1)))); + Replace_Formals (Decl); + Rewrite (Parent (N), Decl); + Analyze (Parent (N)); + + -- Avoid spurious warnings since we know that this declaration is + -- referenced by the procedure call. + + Set_Never_Set_In_Source (Targ, False); + + -- Remove the local declaration of the extended return stmt from the + -- inlined code + + Remove (Parent (Targ1)); + + -- Update the reference to the result (since we have rewriten the + -- object declaration) + + declare + Blk_Call_Stmt : Node_Id; + + begin + -- Capture the call to the procedure + + Blk_Call_Stmt := + First (Statements (Handled_Statement_Sequence (Blk))); + pragma Assert + (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement); + + Remove (First (Parameter_Associations (Blk_Call_Stmt))); + Prepend_To (Parameter_Associations (Blk_Call_Stmt), + New_Occurrence_Of (Targ, Loc)); + end; + + -- Remove the return statement + + pragma Assert + (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = + N_Simple_Return_Statement); + + Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + end if; + + -- Traverse the tree and replace formals with actuals or their thunks. + -- Attach block to tree before analysis and rewriting. + + Replace_Formals (Blk); + Set_Parent (Blk, N); + + if GNATprove_Mode then + null; + + elsif not Comes_From_Source (Subp) or else Is_Predef then + Reset_Slocs (Blk); + end if; + + if Is_Unc_Decl then + + -- No action needed since return statement has been already removed + + null; + + elsif Present (Exit_Lab) then + + -- If the body was a single expression, the single return statement + -- and the corresponding label are useless. + + if Num_Ret = 1 + and then + Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = + N_Goto_Statement + then + Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); + else + Append (Lab_Decl, (Declarations (Blk))); + Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); + end if; + end if; + + -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors + -- on conflicting private views that Gigi would ignore. If this is a + -- predefined unit, analyze with checks off, as is done in the non- + -- inlined run-time units. + + declare + I_Flag : constant Boolean := In_Inlined_Body; + + begin + In_Inlined_Body := True; + + if Is_Predef then + declare + Style : constant Boolean := Style_Check; + + begin + Style_Check := False; + + -- Search for dispatching calls that use the Object.Operation + -- notation using an Object that is a parameter of the inlined + -- function. We reset the decoration of Operation to force + -- the reanalysis of the inlined dispatching call because + -- the actual object has been inlined. + + Reset_Dispatching_Calls (Blk); + + Analyze (Blk, Suppress => All_Checks); + Style_Check := Style; + end; + + else + Analyze (Blk); + end if; + + In_Inlined_Body := I_Flag; + end; + + if Ekind (Subp) = E_Procedure then + Rewrite_Procedure_Call (N, Blk); + + else + Rewrite_Function_Call (N, Blk); + + if Is_Unc_Decl then + null; + + -- For the unconstrained case, the replacement of the call has been + -- made prior to the complete analysis of the generated declarations. + -- Propagate the proper type now. + + elsif Is_Unc then + if Nkind (N) = N_Identifier then + Set_Etype (N, Etype (Entity (N))); + else + Set_Etype (N, Etype (Targ1)); + end if; + end if; + end if; + + Restore_Env; + + -- Cleanup mapping between formals and actuals for other expansions + + F := First_Formal (Subp); + while Present (F) loop + Set_Renamed_Object (F, Empty); + Next_Formal (F); + end loop; + end Expand_Inlined_Call; + + -------------------------- + -- Get_Code_Unit_Entity -- + -------------------------- + + function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is + Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E)); + + begin + if Ekind (Unit) = E_Package_Body then + Unit := Spec_Entity (Unit); + end if; + + return Unit; + end Get_Code_Unit_Entity; + + ------------------------------ + -- Has_Excluded_Declaration -- + ------------------------------ + + function Has_Excluded_Declaration + (Subp : Entity_Id; + Decls : List_Id) return Boolean + is + D : Node_Id; + + function Is_Unchecked_Conversion (D : Node_Id) return Boolean; + -- Nested subprograms make a given body ineligible for inlining, but + -- we make an exception for instantiations of unchecked conversion. + -- The body has not been analyzed yet, so check the name, and verify + -- that the visible entity with that name is the predefined unit. + + ----------------------------- + -- Is_Unchecked_Conversion -- + ----------------------------- + + function Is_Unchecked_Conversion (D : Node_Id) return Boolean is + Id : constant Node_Id := Name (D); + Conv : Entity_Id; + + begin + if Nkind (Id) = N_Identifier + and then Chars (Id) = Name_Unchecked_Conversion + then + Conv := Current_Entity (Id); + + elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) + and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion + then + Conv := Current_Entity (Selector_Name (Id)); + else + return False; + end if; + + return Present (Conv) + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Conv))) + and then Is_Intrinsic_Subprogram (Conv); + end Is_Unchecked_Conversion; + + -- Start of processing for Has_Excluded_Declaration + + begin + -- No action needed if the check is not needed + + if not Check_Inlining_Restrictions then + return False; + end if; + + D := First (Decls); + while Present (D) loop + if Nkind (D) = N_Subprogram_Body then + Cannot_Inline + ("cannot inline & (nested subprogram)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Task_Type_Declaration + or else Nkind (D) = N_Single_Task_Declaration + then + Cannot_Inline + ("cannot inline & (nested task type declaration)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Protected_Type_Declaration + or else Nkind (D) = N_Single_Protected_Declaration + then + Cannot_Inline + ("cannot inline & (nested protected type declaration)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Package_Declaration then + Cannot_Inline + ("cannot inline & (nested package declaration)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Function_Instantiation + and then not Is_Unchecked_Conversion (D) + then + Cannot_Inline + ("cannot inline & (nested function instantiation)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Procedure_Instantiation then + Cannot_Inline + ("cannot inline & (nested procedure instantiation)?", + D, Subp); + return True; + + elsif Nkind (D) = N_Package_Instantiation then + Cannot_Inline + ("cannot inline & (nested package instantiation)?", + D, Subp); + return True; + end if; + + Next (D); + end loop; + + return False; + end Has_Excluded_Declaration; + + ---------------------------- + -- Has_Excluded_Statement -- + ---------------------------- + + function Has_Excluded_Statement + (Subp : Entity_Id; + Stats : List_Id) return Boolean + is + S : Node_Id; + E : Node_Id; + + begin + -- No action needed if the check is not needed + + if not Check_Inlining_Restrictions then + return False; + end if; + + S := First (Stats); + while Present (S) loop + if Nkind_In (S, N_Abort_Statement, + N_Asynchronous_Select, + N_Conditional_Entry_Call, + N_Delay_Relative_Statement, + N_Delay_Until_Statement, + N_Selective_Accept, + N_Timed_Entry_Call) + then + Cannot_Inline + ("cannot inline & (non-allowed statement)?", S, Subp); + return True; + + elsif Nkind (S) = N_Block_Statement then + if Present (Declarations (S)) + and then Has_Excluded_Declaration (Subp, Declarations (S)) + then + return True; + + elsif Present (Handled_Statement_Sequence (S)) then + if not Back_End_Inlining + and then + Present + (Exception_Handlers (Handled_Statement_Sequence (S))) + then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers + (Handled_Statement_Sequence (S))), + Subp); + return True; + + elsif Has_Excluded_Statement + (Subp, Statements (Handled_Statement_Sequence (S))) + then + return True; + end if; + end if; + + elsif Nkind (S) = N_Case_Statement then + E := First (Alternatives (S)); + while Present (E) loop + if Has_Excluded_Statement (Subp, Statements (E)) then + return True; + end if; + + Next (E); + end loop; + + elsif Nkind (S) = N_If_Statement then + if Has_Excluded_Statement (Subp, Then_Statements (S)) then + return True; + end if; + + if Present (Elsif_Parts (S)) then + E := First (Elsif_Parts (S)); + while Present (E) loop + if Has_Excluded_Statement (Subp, Then_Statements (E)) then + return True; + end if; + + Next (E); + end loop; + end if; + + if Present (Else_Statements (S)) + and then Has_Excluded_Statement (Subp, Else_Statements (S)) + then + return True; + end if; + + elsif Nkind (S) = N_Loop_Statement + and then Has_Excluded_Statement (Subp, Statements (S)) + then + return True; + + elsif Nkind (S) = N_Extended_Return_Statement then + if Present (Handled_Statement_Sequence (S)) + and then + Has_Excluded_Statement + (Subp, Statements (Handled_Statement_Sequence (S))) + then + return True; + + elsif not Back_End_Inlining + and then Present (Handled_Statement_Sequence (S)) + and then + Present (Exception_Handlers + (Handled_Statement_Sequence (S))) + then + Cannot_Inline + ("cannot inline& (exception handler)?", + First (Exception_Handlers (Handled_Statement_Sequence (S))), + Subp); + return True; + end if; + end if; + + Next (S); + end loop; + + return False; + end Has_Excluded_Statement; + + -------------------------- + -- Has_Initialized_Type -- + -------------------------- + + function Has_Initialized_Type (E : Entity_Id) return Boolean is + E_Body : constant Node_Id := Get_Subprogram_Body (E); + Decl : Node_Id; + + begin + if No (E_Body) then -- imported subprogram + return False; + + else + Decl := First (Declarations (E_Body)); + while Present (Decl) loop + if Nkind (Decl) = N_Full_Type_Declaration + and then Present (Init_Proc (Defining_Identifier (Decl))) + then + return True; + end if; + + Next (Decl); + end loop; + end if; + + return False; + end Has_Initialized_Type; + + ----------------------- + -- Has_Single_Return -- + ----------------------- + + function Has_Single_Return (N : Node_Id) return Boolean is + Return_Statement : Node_Id := Empty; + + function Check_Return (N : Node_Id) return Traverse_Result; + + ------------------ + -- Check_Return -- + ------------------ + + function Check_Return (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Simple_Return_Statement then + if Present (Expression (N)) + and then Is_Entity_Name (Expression (N)) + then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + elsif Chars (Expression (N)) = + Chars (Expression (Return_Statement)) + then + return OK; + + else + return Abandon; + end if; + + -- A return statement within an extended return is a noop + -- after inlining. + + elsif No (Expression (N)) + and then + Nkind (Parent (Parent (N))) = N_Extended_Return_Statement + then + return OK; + + else + -- Expression has wrong form + + return Abandon; + end if; + + -- We can only inline a build-in-place function if it has a single + -- extended return. + + elsif Nkind (N) = N_Extended_Return_Statement then + if No (Return_Statement) then + Return_Statement := N; + return OK; + + else + return Abandon; + end if; + + else + return OK; + end if; + end Check_Return; + + function Check_All_Returns is new Traverse_Func (Check_Return); + + -- Start of processing for Has_Single_Return + + begin + if Check_All_Returns (N) /= OK then + return False; + + elsif Nkind (Return_Statement) = N_Extended_Return_Statement then + return True; + + else + return Present (Declarations (N)) + and then Present (First (Declarations (N))) + and then Chars (Expression (Return_Statement)) = + Chars (Defining_Identifier (First (Declarations (N)))); + end if; + end Has_Single_Return; + + ----------------------------- + -- In_Main_Unit_Or_Subunit -- + ----------------------------- + + function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is + Comp : Node_Id := Cunit (Get_Code_Unit (E)); + + begin + -- Check whether the subprogram or package to inline is within the main + -- unit or its spec or within a subunit. In either case there are no + -- additional bodies to process. If the subprogram appears in a parent + -- of the current unit, the check on whether inlining is possible is + -- done in Analyze_Inlined_Bodies. + + while Nkind (Unit (Comp)) = N_Subunit loop + Comp := Library_Unit (Comp); + end loop; + + return Comp = Cunit (Main_Unit) + or else Comp = Library_Unit (Cunit (Main_Unit)); end In_Main_Unit_Or_Subunit; ---------------- @@ -1068,6 +3754,11 @@ package body Inline is for J in Hash_Headers'Range loop Hash_Headers (J) := No_Subp; end loop; + + Inlined_Calls := No_Elist; + Backend_Calls := No_Elist; + Backend_Inlined_Subps := No_Elist; + Backend_Not_Inlined_Subps := No_Elist; end Initialize; ------------------------ @@ -1171,6 +3862,141 @@ package body Inline is return False; end Is_Nested; + ------------------------ + -- List_Inlining_Info -- + ------------------------ + + procedure List_Inlining_Info is + Elmt : Elmt_Id; + Nod : Node_Id; + Count : Nat; + + begin + if not Debug_Flag_Dot_J then + return; + end if; + + -- Generate listing of calls inlined by the frontend + + if Present (Inlined_Calls) then + Count := 0; + Elmt := First_Elmt (Inlined_Calls); + while Present (Elmt) loop + Nod := Node (Elmt); + + if In_Extended_Main_Code_Unit (Nod) then + Count := Count + 1; + + if Count = 1 then + Write_Str ("Listing of frontend inlined calls"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Location (Sloc (Nod)); + Write_Str (":"); + Output.Write_Eol; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Generate listing of calls passed to the backend + + if Present (Backend_Calls) then + Count := 0; + + Elmt := First_Elmt (Backend_Calls); + while Present (Elmt) loop + Nod := Node (Elmt); + + if In_Extended_Main_Code_Unit (Nod) then + Count := Count + 1; + + if Count = 1 then + Write_Str ("Listing of inlined calls passed to the backend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Location (Sloc (Nod)); + Output.Write_Eol; + end if; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Generate listing of subprograms passed to the backend + + if Present (Backend_Inlined_Subps) + and then Back_End_Inlining + then + Count := 0; + + Elmt := First_Elmt (Backend_Inlined_Subps); + while Present (Elmt) loop + Nod := Node (Elmt); + + Count := Count + 1; + + if Count = 1 then + Write_Str + ("Listing of inlined subprograms passed to the backend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Name (Chars (Nod)); + Write_Str (" ("); + Write_Location (Sloc (Nod)); + Write_Str (")"); + Output.Write_Eol; + + Next_Elmt (Elmt); + end loop; + end if; + + -- Generate listing of subprogram that cannot be inlined by the backend + + if Present (Backend_Not_Inlined_Subps) + and then Back_End_Inlining + then + Count := 0; + + Elmt := First_Elmt (Backend_Not_Inlined_Subps); + while Present (Elmt) loop + Nod := Node (Elmt); + + Count := Count + 1; + + if Count = 1 then + Write_Str + ("Listing of subprograms that cannot inline the backend"); + Write_Eol; + end if; + + Write_Str (" "); + Write_Int (Count); + Write_Str (":"); + Write_Name (Chars (Nod)); + Write_Str (" ("); + Write_Location (Sloc (Nod)); + Write_Str (")"); + Output.Write_Eol; + + Next_Elmt (Elmt); + end loop; + end if; + end List_Inlining_Info; + ---------- -- Lock -- ---------- @@ -1187,6 +4013,15 @@ package body Inline is Inlined.Release; end Lock; + --------------------------- + -- Register_Backend_Call -- + --------------------------- + + procedure Register_Backend_Call (N : Node_Id) is + begin + Append_New_Elmt (N, To => Backend_Calls); + end Register_Backend_Call; + -------------------------- -- Remove_Dead_Instance -- -------------------------- @@ -1206,4 +4041,31 @@ package body Inline is end loop; end Remove_Dead_Instance; + -------------------- + -- Remove_Pragmas -- + -------------------- + + procedure Remove_Pragmas (Bod : Node_Id) is + Decl : Node_Id; + Nxt : Node_Id; + + begin + Decl := First (Declarations (Bod)); + while Present (Decl) loop + Nxt := Next (Decl); + + if Nkind (Decl) = N_Pragma + and then Nam_In (Pragma_Name (Decl), Name_Contract_Cases, + Name_Precondition, + Name_Postcondition, + Name_Unreferenced, + Name_Unmodified) + then + Remove (Decl); + end if; + + Decl := Nxt; + end loop; + end Remove_Pragmas; + end Inline; diff --git a/main/gcc/ada/inline.ads b/main/gcc/ada/inline.ads index 651a7484c2e..632cbc2c2e5 100644 --- a/main/gcc/ada/inline.ads +++ b/main/gcc/ada/inline.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ --- This module handles two kinds of inlining activity: +-- This module handles four kinds of inlining activity: -- a) Instantiation of generic bodies. This is done unconditionally, after -- analysis and expansion of the main unit. @@ -35,6 +35,15 @@ -- of them uses a workpile algorithm, but they are called independently from -- Frontend, and thus are not mutually recursive. +-- c) Front-end inlining for Inline_Always subprograms. This is primarily an +-- expansion activity that is performed for performance reasons, and when the +-- target does not use the gcc backend. + +-- d) Front-end inlining for GNATprove, to perform source transformations +-- to simplify formal verification. The machinery used is the same than for +-- Inline_Always subprograms, but there are fewer restrictions on the source +-- of subprograms. + with Alloc; with Opt; use Opt; with Sem; use Sem; @@ -122,6 +131,9 @@ package Inline is Table_Increment => Alloc.Pending_Instantiations_Increment, Table_Name => "Pending_Descriptor"); + -- The following should be initialized in an init call in Frontend, we + -- have thoughts of making the frontend reusable in future ??? + ----------------- -- Subprograms -- ----------------- @@ -147,14 +159,109 @@ package Inline is -- At end of compilation, analyze the bodies of all units that contain -- inlined subprograms that are actually called. - procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id); + procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id); + -- If a subprogram has pragma Inline and inlining is active, use generic + -- machinery to build an unexpanded body for the subprogram. This body is + -- subsequently used for inline expansions at call sites. If subprogram can + -- be inlined (depending on size and nature of local declarations) the + -- template body is created. Otherwise subprogram body is treated normally + -- and calls are not inlined in the frontend. If proper warnings are + -- enabled and the subprogram contains a construct that cannot be inlined, + -- the problematic construct is flagged accordingly. + + procedure Cannot_Inline + (Msg : String; + N : Node_Id; + Subp : Entity_Id; + Is_Serious : Boolean := False); + -- This procedure is called if the node N, an instance of a call to + -- subprogram Subp, cannot be inlined. Msg is the message to be issued, + -- which ends with ? (it does not end with ?p?, this routine takes care of + -- the need to change ? to ?p?). The behavior of this routine depends on + -- the value of Back_End_Inlining: + -- + -- * If Back_End_Inlining is not set (ie. legacy frontend inlining model) + -- then if Subp has a pragma Always_Inlined, then an error message is + -- issued (by removing the last character of Msg). If Subp is not + -- Always_Inlined, then a warning is issued if the flag Ineffective_ + -- Inline_Warnings is set, adding ?p to the msg, and if not, the call + -- has no effect. + -- + -- * If Back_End_Inlining is set then: + -- - If Is_Serious is true, then an error is reported (by removing the + -- last character of Msg); + -- + -- - otherwise: + -- + -- * Compiling without optimizations if Subp has a pragma + -- Always_Inlined, then an error message is issued; if Subp is + -- not Always_Inlined, then a warning is issued if the flag + -- Ineffective_Inline_Warnings is set (adding p?), and if not, + -- the call has no effect. + -- + -- * Compiling with optimizations then a warning is issued if the + -- flag Ineffective_Inline_Warnings is set (adding p?); otherwise + -- no effect since inlining may be performed by the backend. + + procedure Check_And_Split_Unconstrained_Function + (N : Node_Id; + Spec_Id : Entity_Id; + Body_Id : Entity_Id); + -- Spec_Id and Body_Id are the entities of the specification and body of + -- the subprogram body N. If N can be inlined by the frontend (supported + -- cases documented in Check_Body_To_Inline) then build the body-to-inline + -- associated with N and attach it to the declaration node of Spec_Id. + + procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id); -- If front-end inlining is enabled and a package declaration contains -- inlined subprograms, load and compile the package body to collect the -- bodies of these subprograms, so they are available to inline calls. -- N is the compilation unit for the package. + procedure Expand_Inlined_Call + (N : Node_Id; + Subp : Entity_Id; + Orig_Subp : Entity_Id); + -- If called subprogram can be inlined by the front-end, retrieve the + -- analyzed body, replace formals with actuals and expand call in place. + -- Generate thunks for actuals that are expressions, and insert the + -- corresponding constant declarations before the call. If the original + -- call is to a derived operation, the return type is the one of the + -- derived operation, but the body is that of the original, so return + -- expressions in the body must be converted to the desired type (which + -- is simply not noted in the tree without inline expansion). + + function Has_Excluded_Declaration + (Subp : Entity_Id; + Decls : List_Id) return Boolean; + -- Check a list of declarations, Decls, that make the inlining of Subp not + -- worthwhile + + function Has_Excluded_Statement + (Subp : Entity_Id; + Stats : List_Id) return Boolean; + -- Check a list of statements, Stats, that make inlining of Subp not + -- worthwhile, including any tasking statement, nested at any level. + + procedure List_Inlining_Info; + -- Generate listing of calls inlined by the frontend plus listing of + -- calls to inline subprograms passed to the backend. + + procedure Register_Backend_Call (N : Node_Id); + -- Append N to the list Backend_Calls + procedure Remove_Dead_Instance (N : Node_Id); -- If an instantiation appears in unreachable code, delete the pending -- body instance. + function Can_Be_Inlined_In_GNATprove_Mode + (Spec_Id : Entity_Id; + Body_Id : Entity_Id) return Boolean; + -- Returns True if the subprogram identified by Spec_Id and Body_Id can + -- be inlined in GNATprove mode. One but not both of Spec_Id and Body_Id + -- can be Empty. Body_Id is Empty when doing a partial check on a call + -- to a subprogram whose body has not been seen yet, to know whether this + -- subprogram could possibly be inlined. GNATprove relies on this to adapt + -- its treatment of the subprogram. + end Inline; diff --git a/main/gcc/ada/interfac.ads b/main/gcc/ada/interfac.ads index fe6bb0f6dea..1c88a507d7d 100644 --- a/main/gcc/ada/interfac.ads +++ b/main/gcc/ada/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, 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 -- @@ -152,19 +152,12 @@ package Interfaces is pragma Import (Intrinsic, Rotate_Left); pragma Import (Intrinsic, Rotate_Right); - -- IEEE Floating point types. Note that the form of these definitions - -- ensures that the work on VMS, even if the standard library is compiled - -- using a Float_Representation pragma for Vax_Float. - - pragma Warnings (Off); - -- Turn off warnings for targets not providing IEEE floating-point types + -- IEEE Floating point types type IEEE_Float_32 is digits 6; - pragma Float_Representation (IEEE_Float, IEEE_Float_32); for IEEE_Float_32'Size use 32; type IEEE_Float_64 is digits 15; - pragma Float_Representation (IEEE_Float, IEEE_Float_64); for IEEE_Float_64'Size use 64; -- If there is an IEEE extended float available on the machine, we assume diff --git a/main/gcc/ada/krunch.adb b/main/gcc/ada/krunch.adb index f2bbf05dce3..79f9de1c82b 100644 --- a/main/gcc/ada/krunch.adb +++ b/main/gcc/ada/krunch.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,15 +29,11 @@ -- -- ------------------------------------------------------------------------------ -with Hostparm; - procedure Krunch (Buffer : in out String; Len : in out Natural; Maxlen : Natural; - No_Predef : Boolean; - VMS_On_Target : Boolean := False) - + No_Predef : Boolean) is pragma Assert (Buffer'First = 1); -- This is a documented requirement; the assert turns off index warnings @@ -120,36 +116,15 @@ begin -- Special case of a child unit whose parent unit is a single letter that -- is A, G, I, or S. In order to prevent confusion with krunched names -- of predefined units use a tilde rather than a minus as the second - -- character of the file name. On VMS a tilde is an illegal character - -- in a file name, two consecutive underlines ("__") are used instead. + -- character of the file name. elsif Len > 1 and then Buffer (2) = '-' and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's') and then Len <= Maxlen then - -- When VMS is the host, it is always also the target - - if Hostparm.OpenVMS or else VMS_On_Target then - Len := Len + 1; - Buffer (4 .. Len) := Buffer (3 .. Len - 1); - Buffer (2) := '_'; - Buffer (3) := '_'; - else - Buffer (2) := '~'; - end if; - - if Len <= Maxlen then - return; - - else - -- Case of VMS when the buffer had exactly the length Maxlen and now - -- has the length Maxlen + 1: krunching after "__" is needed. - - Startloc := 4; - Curlen := Len; - Krlen := Maxlen; - end if; + Buffer (2) := '~'; + return; -- Normal case, not a predefined file @@ -261,5 +236,4 @@ begin end loop; return; - end Krunch; diff --git a/main/gcc/ada/krunch.ads b/main/gcc/ada/krunch.ads index 2a6d9681ed4..7cfb637c57f 100644 --- a/main/gcc/ada/krunch.ads +++ b/main/gcc/ada/krunch.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +121,7 @@ procedure Krunch (Buffer : in out String; Len : in out Natural; Maxlen : Natural; - No_Predef : Boolean; - VMS_On_Target : Boolean := False); + No_Predef : Boolean); pragma Elaborate_Body (Krunch); -- The full file name is stored in Buffer (1 .. Len) on entry. The file -- name is crunched in place and on return Len is updated, so that the @@ -131,8 +130,6 @@ pragma Elaborate_Body (Krunch); -- case it may be possible that Krunch does not modify Buffer. The fourth -- parameter, No_Predef, is a switch which, if set to True, disables the -- normal special treatment of predefined library unit file names. --- VMS_On_Target, when True, indicates to Krunch to apply the VMS treatment --- to the children of package A, G,I or S. -- -- Note: the string Buffer must have a lower bound of 1, and may not -- contain any blanks (in particular, it must not have leading blanks). diff --git a/main/gcc/ada/layout.adb b/main/gcc/ada/layout.adb index d9108c9803c..7721eefdd9d 100644 --- a/main/gcc/ada/layout.adb +++ b/main/gcc/ada/layout.adb @@ -2195,13 +2195,12 @@ package body Layout is D_List := New_List; D_Entity := First_Discriminant (E); while Present (D_Entity) loop - Append ( + Append_To (D_List, Make_Selected_Component (Loc, Prefix => Make_Identifier (Loc, Vname), Selector_Name => - New_Occurrence_Of (D_Entity, Loc)), - D_List); + New_Occurrence_Of (D_Entity, Loc))); D_Entity := Next_Discriminant (D_Entity); end loop; @@ -2526,31 +2525,6 @@ package body Layout is Init_Size (E, System_Address_Size); end if; - -- On VMS, reset size to 32 for convention C access type if no - -- explicit size clause is given and the default size is 64. Really - -- we do not know the size, since depending on options for the VMS - -- compiler, the size of a pointer type can be 32 or 64, but choosing - -- 32 as the default improves compatibility with legacy VMS code. - - -- Note: we do not use Has_Size_Clause in the test below, because we - -- want to catch the case of a derived type inheriting a size clause. - -- We want to consider this to be an explicit size clause for this - -- purpose, since it would be weird not to inherit the size in this - -- case. - - -- We do NOT do this if we are in -gnatdm mode on a non-VMS target - -- since in that case we want the normal pointer representation. - - if Opt.True_VMS_Target - and then (Convention (E) = Convention_C - or else - Convention (E) = Convention_CPP) - and then No (Get_Attribute_Definition_Clause (E, Attribute_Size)) - and then Esize (E) = 64 - then - Init_Size (E, 32); - end if; - Set_Elem_Alignment (E); -- Scalar types: set size and alignment @@ -3022,8 +2996,7 @@ package body Layout is -- If Optimize_Alignment is set to Time, then we reset for odd -- "in between sizes", for example a 17 bit record is given an - -- alignment of 4. Note that this matches the old VMS behavior - -- in versions of GNAT prior to 6.1.1. + -- alignment of 4. elsif Optimize_Alignment_Time (E) and then Siz > System_Storage_Unit diff --git a/main/gcc/ada/lib-load.adb b/main/gcc/ada/lib-load.adb index 262cefe00a7..34b20cc780b 100644 --- a/main/gcc/ada/lib-load.adb +++ b/main/gcc/ada/lib-load.adb @@ -221,6 +221,7 @@ package body Lib.Load is Main_Priority => Default_Main_Priority, Main_CPU => Default_Main_CPU, Munit_Index => 0, + No_Elab_Code_All => False, Serial_Number => 0, Source_Index => No_Source_File, Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), @@ -327,6 +328,7 @@ package body Lib.Load is Main_Priority => Default_Main_Priority, Main_CPU => Default_Main_CPU, Munit_Index => 0, + No_Elab_Code_All => False, Serial_Number => 0, Source_Index => Main_Source_File, Unit_File_Name => Fname, @@ -690,6 +692,7 @@ package body Lib.Load is Main_Priority => Default_Main_Priority, Main_CPU => Default_Main_CPU, Munit_Index => 0, + No_Elab_Code_All => False, Serial_Number => 0, Source_Index => Src_Ind, Unit_File_Name => Fname, diff --git a/main/gcc/ada/lib-load.ads b/main/gcc/ada/lib-load.ads index 3ae9ccaf1aa..a8f779d67da 100644 --- a/main/gcc/ada/lib-load.ads +++ b/main/gcc/ada/lib-load.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -103,14 +103,14 @@ package Lib.Load is -- and then closed on return. function Load_Unit - (Load_Name : Unit_Name_Type; - Required : Boolean; - Error_Node : Node_Id; - Subunit : Boolean; - Corr_Body : Unit_Number_Type := No_Unit; - Renamings : Boolean := False; - With_Node : Node_Id := Empty; - PMES : Boolean := False) return Unit_Number_Type; + (Load_Name : Unit_Name_Type; + Required : Boolean; + Error_Node : Node_Id; + Subunit : Boolean; + Corr_Body : Unit_Number_Type := No_Unit; + Renamings : Boolean := False; + With_Node : Node_Id := Empty; + PMES : Boolean := False) return Unit_Number_Type; -- This function loads and parses the unit specified by Load_Name (or -- returns the unit number for the previously constructed units table -- entry if this is not the first call for this unit). Required indicates diff --git a/main/gcc/ada/lib-util.adb b/main/gcc/ada/lib-util.adb index ae6e204c223..71c05ee170e 100644 --- a/main/gcc/ada/lib-util.adb +++ b/main/gcc/ada/lib-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 +100,9 @@ package body Lib.Util is procedure Write_Info_EOL is begin - if Hostparm.OpenVMS - or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer - then + if Info_Buffer_Len + Max_Line + 1 > Max_Buffer then Write_Info_Terminate; + else -- Delete any trailing blanks diff --git a/main/gcc/ada/lib-writ.adb b/main/gcc/ada/lib-writ.adb index bd0ae5cdc62..1492852468b 100644 --- a/main/gcc/ada/lib-writ.adb +++ b/main/gcc/ada/lib-writ.adb @@ -44,6 +44,7 @@ with Par_SCO; use Par_SCO; with Restrict; use Restrict; with Rident; use Rident; with Scn; use Scn; +with Sem_Eval; use Sem_Eval; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; @@ -89,6 +90,7 @@ package body Lib.Writ is Main_Priority => -1, Main_CPU => -1, Munit_Index => 0, + No_Elab_Code_All => False, Serial_Number => 0, Version => 0, Error_Location => No_Location, @@ -146,6 +148,7 @@ package body Lib.Writ is Main_Priority => -1, Main_CPU => -1, Munit_Index => 0, + No_Elab_Code_All => False, Serial_Number => 0, Version => 0, Error_Location => No_Location, @@ -646,13 +649,27 @@ package body Lib.Writ is for J in 1 .. Notes.Last loop declare - N : constant Node_Id := Notes.Table (J).Pragma_Node; + N : constant Node_Id := Notes.Table (J); L : constant Source_Ptr := Sloc (N); - U : constant Unit_Number_Type := Notes.Table (J).Unit; + U : constant Unit_Number_Type := + Unit (Get_Source_File_Index (L)); C : Character; + Note_Unit : Unit_Number_Type; + -- The unit in whose U section this note must be emitted: + -- notes for subunits are emitted along with the main unit; + -- all other notes are emitted as part of the enclosing + -- compilation unit. + begin - if U = Unit_Num then + if U /= No_Unit and then Nkind (Unit (Cunit (U))) = N_Subunit + then + Note_Unit := Main_Unit; + else + Note_Unit := U; + end if; + + if Note_Unit = Unit_Num then Write_Info_Initiate ('N'); Write_Info_Char (' '); @@ -676,6 +693,15 @@ package body Lib.Writ is Write_Info_Char (':'); Write_Info_Int (Int (Get_Column_Number (L))); + -- Indicate source file of annotation if different from + -- compilation unit source file (case of annotation coming + -- from a separate). + + if Get_Source_File_Index (L) /= Source_Index (Unit_Num) then + Write_Info_Char (':'); + Write_Info_Name (File_Name (Get_Source_File_Index (L))); + end if; + declare A : Node_Id; @@ -697,12 +723,12 @@ package body Lib.Writ is Write_Info_Name (Chars (Expr)); elsif Nkind (Expr) = N_Integer_Literal - and then Is_Static_Expression (Expr) + and then Is_OK_Static_Expression (Expr) then Write_Info_Uint (Intval (Expr)); elsif Nkind (Expr) = N_String_Literal - and then Is_Static_Expression (Expr) + and then Is_OK_Static_Expression (Expr) then Write_Info_Slit (Strval (Expr)); @@ -1107,20 +1133,6 @@ package body Lib.Writ is Write_Info_Str (" DB"); end if; - if Opt.Float_Format /= ' ' then - Write_Info_Str (" F"); - - if Opt.Float_Format = 'I' then - Write_Info_Char ('I'); - - elsif Opt.Float_Format_Long = 'D' then - Write_Info_Char ('D'); - - else - Write_Info_Char ('G'); - end if; - end if; - if Tasking_Used and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit)) then @@ -1158,6 +1170,11 @@ package body Lib.Writ is Write_Info_Str (" NS"); end if; + if Default_SSO_Config /= ' ' then + Write_Info_Str (" O"); + Write_Info_Char (Default_SSO_Config); + end if; + if Sec_Stack_Used then Write_Info_Str (" SS"); end if; diff --git a/main/gcc/ada/lib-writ.ads b/main/gcc/ada/lib-writ.ads index aee3f8f3e41..5a061e49e4d 100644 --- a/main/gcc/ada/lib-writ.ads +++ b/main/gcc/ada/lib-writ.ads @@ -192,18 +192,6 @@ 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). - -- FD Configuration pragmas apply to all the units in this file - -- specifying a possibly non-standard floating point format - -- (VAX float with Long_Float using D_Float). - - -- FG Configuration pragmas apply to all the units in this file - -- specifying a possibly non-standard floating point format - -- (VAX float with Long_Float using G_Float). - - -- FI Configuration pragmas apply to all the units in this file - -- specifying a possibly non-standard floating point format - -- (IEEE Float). - -- Lx A valid Locking_Policy pragma applies to all the units in -- this file, where x is the first character (upper case) of -- the policy name (e.g. 'C' for Ceiling_Locking). @@ -220,6 +208,12 @@ package Lib.Writ is -- NS Normalize_Scalars pragma in effect for all units in -- this file. + -- OH Pragma Default_Scalar_Storage_Order (High_Order_First) is + -- present in a configuration pragma file that applies. + + -- OL Pragma Default_Scalar_Storage_Order (Low_Order_First) is + -- present in a configuration pragma file that applies. + -- Qx A valid Queueing_Policy pragma applies to all the units -- in this file, where x is the first character (upper case) -- of the policy name (e.g. 'P' for Priority_Queueing). @@ -718,7 +712,10 @@ package Lib.Writ is -- T pragma Title -- S pragma Subtitle - -- is the source location of the pragma in line:col format + -- is the source location of the pragma in line:col[:filename] + -- format. The file name is omitted if it is the same as the current + -- unit (it therefore appears explicitly in the case of pragmas + -- occurring in subunits, which do not have U sections of their own). -- Successive entries record the pragma_argument_associations. @@ -920,7 +917,8 @@ package Lib.Writ is procedure Write_ALI (Object : Boolean); -- This procedure writes the library information for the current main unit -- The Object parameter is true if an object file is created, and false - -- otherwise. + -- otherwise. Note that the pseudo-object file generated in GNATProve mode + -- does count as an object file from this point of view. -- -- Note: in the case where we are not generating code (-gnatc mode), this -- routine only writes an ALI file if it cannot find an existing up to diff --git a/main/gcc/ada/lib-xref-spark_specific.adb b/main/gcc/ada/lib-xref-spark_specific.adb index 7e7d52bb07b..28677060aae 100644 --- a/main/gcc/ada/lib-xref-spark_specific.adb +++ b/main/gcc/ada/lib-xref-spark_specific.adb @@ -485,7 +485,6 @@ package body SPARK_Specific is declare Dummy : constant SPARK_Scope_Record := SPARK_Scope_Table.Table (Index); - pragma Unreferenced (Dummy); begin return True; end; diff --git a/main/gcc/ada/lib-xref.adb b/main/gcc/ada/lib-xref.adb index 95c87ef7194..a913884a6d7 100644 --- a/main/gcc/ada/lib-xref.adb +++ b/main/gcc/ada/lib-xref.adb @@ -955,6 +955,14 @@ package body Lib.Xref is if Comes_From_Source (E) then Ent := E; + -- Because a declaration may be generated for a subprogram body + -- without declaration in GNATprove mode, for inlining, some + -- parameters may end up being marked as not coming from source + -- although they are. Take these into account specially. + + elsif GNATprove_Mode and then Ekind (E) in Formal_Kind then + Ent := E; + -- Entity does not come from source, but is a derived subprogram and -- the derived subprogram comes from source (after one or more -- derivations) in which case the reference is to parent subprogram. @@ -1893,12 +1901,18 @@ package body Lib.Xref is procedure Check_Type_Reference (Ent : Entity_Id; - List_Interface : Boolean); + List_Interface : Boolean; + Is_Component : Boolean := False); -- Find whether there is a meaningful type reference for -- Ent, and display it accordingly. If List_Interface is -- true, then Ent is a progenitor interface of the current -- type entity being listed. In that case list it as is, - -- without looking for a type reference for it. + -- without looking for a type reference for it. Flag is also + -- used for index types of an array type, where the caller + -- supplies the intended type reference. Is_Component serves + -- the same purpose, to display the component type of a + -- derived array type, for which only the parent type has + -- ben displayed so far. procedure Output_Instantiation_Refs (Loc : Source_Ptr); -- Recursive procedure to output instantiation references for @@ -1915,7 +1929,8 @@ package body Lib.Xref is procedure Check_Type_Reference (Ent : Entity_Id; - List_Interface : Boolean) + List_Interface : Boolean; + Is_Component : Boolean := False) is begin if List_Interface then @@ -1927,6 +1942,13 @@ package body Lib.Xref is Left := '<'; Right := '>'; + -- The following is not documented in lib-xref.ads ??? + + elsif Is_Component then + Tref := Ent; + Left := '('; + Right := ')'; + else Get_Type_Reference (Ent, Tref, Left, Right); end if; @@ -2515,8 +2537,21 @@ package body Lib.Xref is if Is_Array_Type (XE.Key.Ent) then declare + A_Typ : constant Entity_Id := XE.Key.Ent; Indx : Node_Id; + begin + -- If this is a derived array type, we have + -- output the parent type, so add the component + -- type now. + + if Is_Derived_Type (A_Typ) then + Check_Type_Reference + (Component_Type (A_Typ), False, True); + end if; + + -- Add references to index types. + Indx := First_Index (XE.Key.Ent); while Present (Indx) loop Check_Type_Reference diff --git a/main/gcc/ada/lib-xref.ads b/main/gcc/ada/lib-xref.ads index 17733a0c930..b82f4b837c8 100644 --- a/main/gcc/ada/lib-xref.ads +++ b/main/gcc/ada/lib-xref.ads @@ -502,14 +502,18 @@ package Lib.Xref is E_Signed_Integer_Subtype => 'I', E_Signed_Integer_Type => 'I', E_String_Literal_Subtype => ' ', - E_String_Subtype => 'S', - E_String_Type => 'S', E_Subprogram_Type => ' ', E_Task_Subtype => 'T', E_Task_Type => 'T', E_Variable => '*', E_Void => ' ', + -- These are dummy entries which can be removed when we finally get + -- rid of these obsolete entries once and for all. + + E_String_Type => ' ', + E_String_Subtype => ' ', + -- 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 diff --git a/main/gcc/ada/lib.adb b/main/gcc/ada/lib.adb index 296a6b9a1d1..609a03c5592 100644 --- a/main/gcc/ada/lib.adb +++ b/main/gcc/ada/lib.adb @@ -146,6 +146,11 @@ package body Lib is return Units.Table (U).Munit_Index; end Munit_Index; + function No_Elab_Code_All (U : Unit_Number_Type) return Boolean is + begin + return Units.Table (U).No_Elab_Code_All; + end No_Elab_Code_All; + function OA_Setting (U : Unit_Number_Type) return Character is begin return Units.Table (U).OA_Setting; @@ -226,6 +231,14 @@ package body Lib is Units.Table (U).Main_Priority := P; end Set_Main_Priority; + procedure Set_No_Elab_Code_All + (U : Unit_Number_Type; + B : Boolean := True) + is + begin + Units.Table (U).No_Elab_Code_All := B; + end Set_No_Elab_Code_All; + procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is begin Units.Table (U).OA_Setting := C; @@ -1046,8 +1059,17 @@ package body Lib is ---------------- procedure Store_Note (N : Node_Id) is + Sfile : constant Source_File_Index := Get_Source_File_Index (Sloc (N)); + begin - Notes.Append ((Pragma_Node => N, Unit => Current_Sem_Unit)); + -- Notes for a generic are emitted when processing the template, never + -- in instances. + + if In_Extended_Main_Code_Unit (N) + and then Instance (Sfile) = No_Instance_Id + then + Notes.Append (N); + end if; end Store_Note; ------------------------------- diff --git a/main/gcc/ada/lib.ads b/main/gcc/ada/lib.ads index 0de88fec708..4a9f7deac5f 100644 --- a/main/gcc/ada/lib.ads +++ b/main/gcc/ada/lib.ads @@ -347,6 +347,11 @@ package Lib is -- The index of the unit within the file for multiple unit per file -- mode. Set to zero in normal single unit per file mode. + -- No_Elab_Code_All + -- A flag set when a pragma or aspect No_Elaboration_Code_All applies + -- to the unit. This is used to implement the transitive WITH rules + -- (and for no other purpose). + -- OA_Setting -- This is a character field containing L if Optimize_Alignment mode -- was set locally, and O/T/S for Off/Time/Space default if not. @@ -410,6 +415,7 @@ package Lib is 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; @@ -426,6 +432,7 @@ package Lib is procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); procedure Set_Main_CPU (U : Unit_Number_Type; P : Int); + procedure Set_No_Elab_Code_All (U : Unit_Number_Type; B : Boolean := True); procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); procedure Set_OA_Setting (U : Unit_Number_Type; C : Character); procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); @@ -726,6 +733,7 @@ private pragma Inline (Main_CPU); pragma Inline (Main_Priority); pragma Inline (Munit_Index); + pragma Inline (No_Elab_Code_All); pragma Inline (OA_Setting); pragma Inline (Set_Cunit); pragma Inline (Set_Cunit_Entity); @@ -735,6 +743,7 @@ private pragma Inline (Set_Loading); pragma Inline (Set_Main_CPU); pragma Inline (Set_Main_Priority); + pragma Inline (Set_No_Elab_Code_All); pragma Inline (Set_OA_Setting); pragma Inline (Set_Unit_Name); pragma Inline (Source_Index); @@ -760,6 +769,7 @@ private Generate_Code : Boolean; Has_RACW : Boolean; Dynamic_Elab : Boolean; + No_Elab_Code_All : Boolean; Filler : Boolean; Loading : Boolean; OA_Setting : Character; @@ -789,7 +799,8 @@ private Generate_Code at 57 range 0 .. 7; Has_RACW at 58 range 0 .. 7; Dynamic_Elab at 59 range 0 .. 7; - Filler at 60 range 0 .. 15; + No_Elab_Code_All at 60 range 0 .. 7; + Filler at 61 range 0 .. 7; OA_Setting at 62 range 0 .. 7; Loading at 63 range 0 .. 7; SPARK_Mode_Pragma at 64 range 0 .. 31; @@ -826,13 +837,8 @@ private -- The following table stores references to pragmas that generate Notes - type Notes_Entry is record - Pragma_Node : Node_Id; - Unit : Unit_Number_Type; - end record; - package Notes is new Table.Table ( - Table_Component_Type => Notes_Entry, + Table_Component_Type => Node_Id, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => Alloc.Notes_Initial, diff --git a/main/gcc/ada/link.c b/main/gcc/ada/link.c index 8a8e12033d7..ee591471af0 100644 --- a/main/gcc/ada/link.c +++ b/main/gcc/ada/link.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, Free Software Foundation, Inc. * * * * GNAT is 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 @@ const char *__gnat_run_path_option = ""; char __gnat_shared_libgnat_default = STATIC; char __gnat_shared_libgcc_default = STATIC; int __gnat_link_max = 15000; -const unsigned char __gnat_objlist_file_supported = 1; +unsigned char __gnat_objlist_file_supported = 1; const char *__gnat_object_library_extension = ".a"; unsigned char __gnat_separate_run_path_options = 0; const char *__gnat_default_libgcc_subdir = "lib"; diff --git a/main/gcc/ada/make.adb b/main/gcc/ada/make.adb index a426df6c63a..07f960bddeb 100644 --- a/main/gcc/ada/make.adb +++ b/main/gcc/ada/make.adb @@ -68,9 +68,9 @@ with Targparm; use Targparm; with Tempdir; with Types; use Types; -with Ada.Command_Line; use Ada.Command_Line; +with Ada.Command_Line; use Ada.Command_Line; with Ada.Directories; -with Ada.Exceptions; use Ada.Exceptions; +with Ada.Exceptions; use Ada.Exceptions; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Command_Line; use GNAT.Command_Line; @@ -1986,7 +1986,7 @@ package body Make is D_Chk : for D in ALIs.Table (ALI).First_Sdep .. - ALIs.Table (ALI).Last_Sdep + ALIs.Table (ALI).Last_Sdep loop Dep := Sdep.Table (D); UID := Units_Htable.Get_First (Project_Tree.Units_HT); @@ -2256,6 +2256,8 @@ package body Make is Is_Main_Source : Boolean; Args : Argument_List) is + pragma Unreferenced (Is_Main_Source); + begin Arguments_Project := No_Project; Last_Argument := 0; @@ -2283,8 +2285,7 @@ package body Make is if Arguments_Project = No_Project then Add_Arguments (The_Saved_Gcc_Switches.all); - elsif not Arguments_Project.Externally_Built - or else Must_Compile + elsif not Arguments_Project.Externally_Built or else Must_Compile then -- We get the project directory for the relative path -- switches and arguments. @@ -2337,7 +2338,6 @@ package body Make is -- plus the saved gcc switches. when List => - declare Current : String_List_Id := Switches.Values; Element : String_Element; @@ -2424,29 +2424,6 @@ package body Make is end; end if; - -- For VMS, when compiling the main source, add switch - -- -mdebug-main=_ada_ so that the executable can be debugged - -- by the standard VMS debugger. - - if not No_Main_Subprogram - and then Targparm.OpenVMS_On_Target - and then Is_Main_Source - then - -- First, check if compilation will be invoked with -g - - for J in 1 .. Last_Argument loop - if Arguments (J)'Length >= 2 - and then Arguments (J) (1 .. 2) = "-g" - and then (Arguments (J)'Length < 5 - or else Arguments (J) (1 .. 5) /= "-gnat") - then - Add_Arguments - ((1 => new String'("-mdebug-main=_ada_"))); - exit; - end if; - end loop; - end if; - -- Set Output_Is_Object, depending if there is a -S switch. -- If the bind step is not performed, and there is a -S switch, -- then we will not check for a valid object file. @@ -2647,65 +2624,58 @@ package body Make is Data := No_Compilation_Data; OK := False; - -- The loop here is a work-around for a problem on VMS; in some - -- circumstances (shared library and several executables, for - -- example), there are child processes other than compilation - -- processes that are received. Until this problem is resolved, - -- we will ignore such processes. - - loop - Wait_Process (Pid, OK); + Wait_Process (Pid, OK); - if Pid = Invalid_Pid then - return; - end if; + if Pid = Invalid_Pid then + return; + end if; - for J in Running_Compile'First .. Outstanding_Compiles loop - if Pid = Running_Compile (J).Pid then - Data := Running_Compile (J); - Project := Running_Compile (J).Project; + -- Look into the running compilation processes for this PID - if Project /= No_Project then - Queue.Set_Obj_Dir_Free (Project.Object_Directory.Name); - end if; + for J in Running_Compile'First .. Outstanding_Compiles loop + if Pid = Running_Compile (J).Pid then + Data := Running_Compile (J); + Project := Running_Compile (J).Project; - -- If a mapping file was used by this compilation, get its - -- file name for reuse by a subsequent compilation. - - if Running_Compile (J).Mapping_File /= No_Mapping_File then - Comp_Data := - Project_Compilation_Htable.Get - (Project_Compilation, Project); - Comp_Data.Last_Free_Indexes := - Comp_Data.Last_Free_Indexes + 1; - Comp_Data.Free_Mapping_File_Indexes - (Comp_Data.Last_Free_Indexes) := - Running_Compile (J).Mapping_File; - end if; + if Project /= No_Project then + Queue.Set_Obj_Dir_Free (Project.Object_Directory.Name); + end if; - -- To actually remove this Pid and related info from - -- Running_Compile replace its entry with the last valid - -- entry in Running_Compile. + -- If a mapping file was used by this compilation, get its file + -- name for reuse by a subsequent compilation. + + if Running_Compile (J).Mapping_File /= No_Mapping_File then + Comp_Data := + Project_Compilation_Htable.Get + (Project_Compilation, Project); + Comp_Data.Last_Free_Indexes := + Comp_Data.Last_Free_Indexes + 1; + Comp_Data.Free_Mapping_File_Indexes + (Comp_Data.Last_Free_Indexes) := + Running_Compile (J).Mapping_File; + end if; - if J = Outstanding_Compiles then - null; - else - Running_Compile (J) := - Running_Compile (Outstanding_Compiles); - end if; + -- To actually remove this Pid and related info from + -- Running_Compile replace its entry with the last valid + -- entry in Running_Compile. - Outstanding_Compiles := Outstanding_Compiles - 1; - return; + if J = Outstanding_Compiles then + null; + else + Running_Compile (J) := + Running_Compile (Outstanding_Compiles); end if; - end loop; - -- This child process was not one of our compilation processes; - -- just ignore it for now. + Outstanding_Compiles := Outstanding_Compiles - 1; + exit; + end if; + end loop; - -- Why is this commented out code sitting here??? + -- If the PID was not found, return with OK set to False - -- raise Program_Error; - end loop; + if Data = No_Compilation_Data then + OK := False; + end if; end Await_Compile; --------------------------- @@ -3816,7 +3786,7 @@ package body Make is -- Delete any temporary configuration pragma file - if not Debug.Debug_Flag_N then + if not Keep_Temporary_Files then Delete_Temp_Config_Files (Project_Tree); end if; end Compile_Sources; @@ -3994,7 +3964,7 @@ package body Make is -- created when using a project file. if Main_Project = No_Project - or else Debug.Debug_Flag_N + or else Opt.Keep_Temporary_Files or else Args (J)'Length < 8 or else Args (J) (Args (J)'First .. Args (J)'First + 6) /= "-gnatem" @@ -4005,18 +3975,18 @@ package body Make is -- Reset Temporary_Config_File to False so that the eventual -- other -gnatec switches will be displayed. - if (not Debug.Debug_Flag_N) + if not Opt.Keep_Temporary_Files and then Temporary_Config_File and then Args (J)'Length > 7 - and then Args (J) (Args (J)'First .. Args (J)'First + 6) - = "-gnatec" + and then Args (J) (Args (J)'First .. Args (J)'First + 6) = + "-gnatec" then Temporary_Config_File := False; -- Do not display the -F=mapping_file switch for gnatbind -- if -dn is not specified. - elsif Debug.Debug_Flag_N + elsif Opt.Keep_Temporary_Files or else Args (J)'Length < 4 or else Args (J) (Args (J)'First .. Args (J)'First + 2) /= "-F=" @@ -4029,6 +3999,7 @@ package body Make is if Debug.Debug_Flag_F then declare Equal_Pos : Natural; + begin Equal_Pos := Args (J)'First - 1; for K in Args (J)'Range loop @@ -4137,6 +4108,8 @@ package body Make is procedure Globalize_Dirs is new Prj.Env.For_All_Object_Dirs (Globalize_Dir); + -- Start of procedure Globalize + begin Success := True; Display (Globalizer, Globalizer_Args); @@ -4228,12 +4201,8 @@ package body Make is end loop; for Index in 1 .. Library_Projs.Last loop - if - Library_Projs.Table (Index).Extended_By = No_Project - then - if Library_Projs.Table (Index).Library_Kind = Static - and then not Targparm.OpenVMS_On_Target - then + if Library_Projs.Table (Index).Extended_By = No_Project then + if Library_Projs.Table (Index).Library_Kind = Static then Linker_Switches.Increment_Last; Linker_Switches.Table (Linker_Switches.Last) := new String' @@ -4309,8 +4278,7 @@ package body Make is -- We are going to create one switch of the form -- "-Wl,-rpath,dir_1:dir_2:dir_3" - for Index in - Library_Paths.First .. Library_Paths.Last + for Index in Library_Paths.First .. Library_Paths.Last loop -- Add the length of the library dir plus one for the -- directory separator. @@ -4330,8 +4298,7 @@ package body Make is -- Put each library dir followed by a dir -- separator. - for Index in - Library_Paths.First .. Library_Paths.Last + for Index in Library_Paths.First .. Library_Paths.Last loop Option (Current + 1 .. @@ -4422,8 +4389,8 @@ package body Make is -- need to do the duplication since the arguments will get -- normalized. Not doing so will result in calling normalized -- two times for the same set of arguments if gnatmake is - -- passed multiple mains. This can result in the wrong argument - -- being passed to the linker. + -- passed multiple mains. This can result in the wrong + -- argument being passed to the linker. else Last_Arg := Last_Arg + 1; @@ -4444,6 +4411,7 @@ package body Make is declare Success : Boolean := False; + begin -- If gnatmake was invoked with --subdirs and no project file, -- put the executable in the subdirectory specified. @@ -4461,9 +4429,7 @@ package body Make is Successful_Links.Increment_Last; Successful_Links.Table (Successful_Links.Last) := Main_ALI_File; - elsif Osint.Number_Of_Files = 1 - or else not Keep_Going - then + elsif Osint.Number_Of_Files = 1 or else not Keep_Going then Make_Failed ("*** link failed."); else @@ -4633,8 +4599,7 @@ package body Make is Proj1 : Project_List; procedure Add_To_Library_Projs (Proj : Project_Id); - -- Add project Project to table Library_Projs in - -- decreasing depth order. + -- Add project Project to table Library_Projs in decreasing depth order -------------------------- -- Add_To_Library_Projs -- @@ -4661,11 +4626,13 @@ package body Make is Library_Projs.Table (Current) := Proj; end Add_To_Library_Projs; + -- Start of processing for Library_Phase + begin Library_Projs.Init; - -- Put in Library_Projs table all library project file - -- ids when the library need to be rebuilt. + -- Put in Library_Projs table all library project file ids when the + -- library need to be rebuilt. Proj1 := Project_Tree.Projects; while Proj1 /= null loop @@ -4777,7 +4744,6 @@ package body Make is Stop_Compile : out Boolean) is Args : Argument_List (1 .. Gcc_Switches.Last); - First_Compiled_File : File_Name_Type; Youngest_Obj_File : File_Name_Type; Youngest_Obj_Stamp : Time_Stamp_Type; @@ -5109,8 +5075,7 @@ package body Make is -- If there is no object directory, then it will be -- impossible to build the library, so fail immediately. - if Proj.Project.Object_Directory = - No_Path_Information + if Proj.Project.Object_Directory = No_Path_Information then Make_Failed ("no object files to build library for" @@ -5235,6 +5200,10 @@ package body Make is -- Handles builder and global compilation switches, as read from the -- project file. + ------------------------- + -- Add_Global_Switches -- + ------------------------- + function Add_Global_Switches (Switch : String; For_Lang : Name_Id; @@ -5242,6 +5211,7 @@ package body Make is Has_Global_Compilation_Switches : Boolean) return Boolean is pragma Unreferenced (For_Lang); + begin if For_Builder then Program_Args := None; @@ -5258,12 +5228,15 @@ package body Make is end Add_Global_Switches; procedure Do_Compute_Builder_Switches - is new Makeutl.Compute_Builder_Switches (Add_Global_Switches); + is new Makeutl.Compute_Builder_Switches (Add_Global_Switches); + + -- Start of processing for Compute_Switches_For_Main + begin if Main_Project /= No_Project then declare Main_Source_File_Name : constant String := - Get_Name_String (Main_Source_File); + Get_Name_String (Main_Source_File); Main_Unit_File_Name : constant String := Prj.Env.File_Name_Of_Library_Unit_Body @@ -5394,6 +5367,7 @@ package body Make is declare Dir_Path : constant String := Get_Name_String (Main_Project.Directory.Display_Name); + begin for J in Last_Binder_Switch + 1 .. Binder_Switches.Last loop Ensure_Absolute_Path @@ -5501,6 +5475,7 @@ package body Make is Real_Main_Project : Project_Id := No_Project; Info : Main_Info; Proj : Project_Id; + begin if Mains.Number_Of_Mains (Project_Tree) = 0 and then not Unique_Compile @@ -5669,7 +5644,6 @@ package body Make is -- else gnatmake was invoked with the switch "-u". if Value = Prj.Nil_String or else Unique_Compile then - if not Make_Steps or Compile_Only or not Main_Project.Library @@ -5816,9 +5790,7 @@ package body Make is if Osint.Number_Of_Files = 0 then if Main_Project /= No_Project and then Main_Project.Library then - if Do_Bind_Step - and then Main_Project.Standalone_Library = No - then + if Do_Bind_Step and then Main_Project.Standalone_Library = No then Make_Failed ("only stand-alone libraries may be bound"); end if; @@ -5826,17 +5798,6 @@ package body Make is Osint.Add_Default_Search_Dirs; - -- Get the target parameters, so that the correct binder generated - -- files are generated if OpenVMS is the target. - - begin - Targparm.Get_Target_Parameters; - - exception - when Unrecoverable_Error => - Make_Failed ("*** make failed."); - end; - -- And bind and or link the library MLib.Prj.Build_Library @@ -6021,7 +5982,7 @@ package body Make is if Current_Main_Index = 0 and then Unique_Compile - and then Main_Project /= No_Project + and then Main_Project /= No_Project then -- If this is a multi-unit source, do not compile it as is (ie -- without specifying which unit to compile) @@ -6035,9 +5996,7 @@ package body Make is Index => Current_Main_Index, In_Imported_Only => True); begin - if Source /= No_Source - and then Source.Index /= 0 - then + if Source /= No_Source and then Source.Index /= 0 then goto Next_Main; end if; end; @@ -6129,26 +6088,28 @@ package body Make is begin Proj := Project_Tree.Projects; while Proj /= null loop - Data := new Project_Compilation_Data' - (Mapping_File_Names => new Temp_Path_Names - (1 .. Saved_Maximum_Processes), - Last_Mapping_File_Names => 0, - Free_Mapping_File_Indexes => new Free_File_Indexes - (1 .. Saved_Maximum_Processes), - Last_Free_Indexes => 0); + Data := + new Project_Compilation_Data' + (Mapping_File_Names => + new Temp_Path_Names (1 .. Saved_Maximum_Processes), + Last_Mapping_File_Names => 0, + Free_Mapping_File_Indexes => + new Free_File_Indexes (1 .. Saved_Maximum_Processes), + Last_Free_Indexes => 0); Project_Compilation_Htable.Set (Project_Compilation, Proj.Project, Data); Proj := Proj.Next; end loop; - Data := new Project_Compilation_Data' - (Mapping_File_Names => new Temp_Path_Names - (1 .. Saved_Maximum_Processes), - Last_Mapping_File_Names => 0, - Free_Mapping_File_Indexes => new Free_File_Indexes - (1 .. Saved_Maximum_Processes), - Last_Free_Indexes => 0); + Data := + new Project_Compilation_Data' + (Mapping_File_Names => + new Temp_Path_Names (1 .. Saved_Maximum_Processes), + Last_Mapping_File_Names => 0, + Free_Mapping_File_Indexes => + new Free_File_Indexes (1 .. Saved_Maximum_Processes), + Last_Free_Indexes => 0); Project_Compilation_Htable.Set (Project_Compilation, No_Project, Data); @@ -6361,12 +6322,10 @@ package body Make is else Tempdir.Create_Temp_File - (FD, - Data.Mapping_File_Names (Data.Last_Mapping_File_Names)); + (FD, Data.Mapping_File_Names (Data.Last_Mapping_File_Names)); if FD = Invalid_FD then Make_Failed ("disk full"); - else Record_Temp_File (Project_Tree.Shared, @@ -6396,7 +6355,7 @@ package body Make is procedure Check_Version_And_Help is new Check_Version_And_Help_G (Makeusg); - -- Start of processing for Initialize + -- Start of processing for Initialize begin -- Prepare the project's tree, since this is used to hold external @@ -6438,45 +6397,42 @@ package body Make is -- Add the directory where gnatmake is invoked in front of the path, -- if gnatmake is invoked from a bin directory or with directory - -- information. Only do this if the platform is not VMS, where the - -- notion of path does not really exist. + -- information. - if not OpenVMS then - declare - Prefix : constant String := Executable_Prefix_Path; - Command : constant String := Command_Name; + declare + Prefix : constant String := Executable_Prefix_Path; + Command : constant String := Command_Name; - begin - if Prefix'Length > 0 then - declare - PATH : constant String := - Prefix & Directory_Separator & "bin" & Path_Separator & - Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; + begin + if Prefix'Length > 0 then + declare + PATH : constant String := + Prefix & Directory_Separator & "bin" & Path_Separator + & Getenv ("PATH").all; + begin + Setenv ("PATH", PATH); + end; - else - for Index in reverse Command'Range loop - if Command (Index) = Directory_Separator then - declare - Absolute_Dir : constant String := - Normalize_Pathname - (Command (Command'First .. Index)); - PATH : constant String := - Absolute_Dir & - Path_Separator & - Getenv ("PATH").all; - begin - Setenv ("PATH", PATH); - end; + else + for Index in reverse Command'Range loop + if Command (Index) = Directory_Separator then + declare + Absolute_Dir : constant String := + Normalize_Pathname + (Command (Command'First .. Index)); + PATH : constant String := + Absolute_Dir & + Path_Separator & + Getenv ("PATH").all; + begin + Setenv ("PATH", PATH); + end; - exit; - end if; - end loop; - end if; - end; - end if; + exit; + end if; + end loop; + end if; + end; -- Scan the switches and arguments @@ -6516,16 +6472,12 @@ package body Make is -- Test for trailing -o switch - elsif Output_File_Name_Present - and then not Output_File_Name_Seen - then + elsif Output_File_Name_Present and then not Output_File_Name_Seen then Make_Failed ("output file name missing after -o"); -- Test for trailing -D switch - elsif Object_Directory_Present - and then not Object_Directory_Seen - then + elsif Object_Directory_Present and then not Object_Directory_Seen then Make_Failed ("object directory missing after -D"); end if; @@ -6692,6 +6644,9 @@ package body Make is Project_Of_Current_Object_Directory := No_Project; + if Debug.Debug_Flag_N then + Opt.Keep_Temporary_Files := True; + end if; end Initialize; ---------------------------- @@ -6781,8 +6736,8 @@ package body Make is and then not Unit.File_Names (Spec).Locally_Removed and then (All_Projects - or else - Is_Extending (The_Project, Unit.File_Names (Spec).Project)) + or else + Is_Extending (The_Project, Unit.File_Names (Spec).Project)) then -- If there is no source for the body, but there is one for the -- spec which has not been locally removed, then we take this one. @@ -6985,15 +6940,17 @@ package body Make is procedure List_Bad_Compilations is begin - for J in Bad_Compilation.First .. Bad_Compilation.Last loop - if Bad_Compilation.Table (J).File = No_File then - null; - elsif not Bad_Compilation.Table (J).Found then - Inform (Bad_Compilation.Table (J).File, "not found"); - else - Inform (Bad_Compilation.Table (J).File, "compilation error"); - end if; - end loop; + if not No_Exit_Message then + for J in Bad_Compilation.First .. Bad_Compilation.Last loop + if Bad_Compilation.Table (J).File = No_File then + null; + elsif not Bad_Compilation.Table (J).Found then + Inform (Bad_Compilation.Table (J).File, "not found"); + else + Inform (Bad_Compilation.Table (J).File, "compilation error"); + end if; + end loop; + end if; end List_Bad_Compilations; ----------------- @@ -7444,9 +7401,7 @@ package body Make is -- A special test is needed for the -o switch within a -largs since that -- is another way to specify the name of the final executable. - elsif Program_Args = Linker - and then Argv = "-o" - then + elsif Program_Args = Linker and then Argv = "-o" then Make_Failed ("switch -o not allowed within a -largs. Use -o directly."); diff --git a/main/gcc/ada/makeusg.adb b/main/gcc/ada/makeusg.adb index 16eb5f968b1..580a3730a9e 100644 --- a/main/gcc/ada/makeusg.adb +++ b/main/gcc/ada/makeusg.adb @@ -265,6 +265,9 @@ begin Write_Str (" Create map file mapfile"); Write_Eol; + Write_Str (" --keep-temp-files Keep temporary files"); + Write_Eol; + Write_Str (" --GCC=command Use this gcc command"); Write_Eol; diff --git a/main/gcc/ada/makeutl.adb b/main/gcc/ada/makeutl.adb index 3b72ed70a0f..cbfd01e49d3 100644 --- a/main/gcc/ada/makeutl.adb +++ b/main/gcc/ada/makeutl.adb @@ -29,7 +29,6 @@ with Debug; with Err_Vars; use Err_Vars; with Errutil; with Fname; -with Hostparm; with Osint; use Osint; with Output; use Output; with Opt; use Opt; @@ -624,13 +623,11 @@ package body Makeutl is end if; elsif Sw'Length >= 4 - and then (Sw (2 .. 3) = "aL" - or else - Sw (2 .. 3) = "aO" - or else - Sw (2 .. 3) = "aI" - or else - (For_Gnatbind and then Sw (2 .. 3) = "A=")) + and then + (Sw (2 .. 3) = "aL" or else + Sw (2 .. 3) = "aO" or else + Sw (2 .. 3) = "aI" + or else (For_Gnatbind and then Sw (2 .. 3) = "A=")) then Start := 4; @@ -742,12 +739,6 @@ package body Makeutl is -- Beginning of Executable_Prefix_Path begin - -- For VMS, the path returned is always /gnu/ - - if Hostparm.OpenVMS then - return "/gnu/"; - end if; - -- First determine if a path prefix was placed in front of the -- executable name. @@ -786,7 +777,7 @@ package body Makeutl is Flush_Messages : Boolean := True) is begin - if Flush_Messages then + if Flush_Messages and not No_Exit_Message then if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then Errutil.Finalize; end if; @@ -815,8 +806,13 @@ package body Makeutl is if S'Length > 0 then if Exit_Code /= E_Success then - Osint.Fail (S); - else + if No_Exit_Message then + Osint.Exit_Program (E_Fatal); + else + Osint.Fail (S); + end if; + + elsif not No_Exit_Message then Write_Str (S); end if; end if; @@ -1434,8 +1430,6 @@ package body Makeutl is In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is - pragma Unreferenced (Dummy); - Linker_Package : Package_Id; Options : Variable_Value; @@ -2564,7 +2558,7 @@ package body Makeutl is if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name and then Source.Id.Index = Q.Table (J).Info.Id.Index and then Source.Id.Project.Path.Name = - Q.Table (J).Info.Id.Project.Path.Name + Q.Table (J).Info.Id.Project.Path.Name then -- No need to insert this source in the queue, but still -- return True as we may need to insert its roots. @@ -2621,7 +2615,6 @@ package body Makeutl is Iter : Source_Iterator; Dummy : Boolean; - pragma Unreferenced (Dummy); begin if not Insert_No_Roots (Source) then @@ -2757,9 +2750,10 @@ package body Makeutl is Debug_Output (" -> ", Name_Id (Root_Source.Display_File)); Dummy := Queue.Insert_No_Roots - (Source => (Format => Format_Gprbuild, - Tree => Source.Tree, - Id => Root_Source)); + (Source => (Format => Format_Gprbuild, + Tree => Source.Tree, + Id => Root_Source, + Closure => False)); Initialize_Source_Record (Root_Source); @@ -2811,7 +2805,6 @@ package body Makeutl is With_Roots : Boolean := False) is Discard : Boolean; - pragma Unreferenced (Discard); begin Discard := Insert (Source, With_Roots); end Insert; @@ -2915,31 +2908,39 @@ package body Makeutl is All_Projects : Boolean; Unique_Compile : Boolean) is - procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref); + + procedure Do_Insert + (Project : Project_Id; + Tree : Project_Tree_Ref; + Context : Project_Context); + -- Local procedures must be commented ??? --------------- -- Do_Insert -- --------------- - procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref) is + procedure Do_Insert + (Project : Project_Id; + Tree : Project_Tree_Ref; + Context : Project_Context) + is Unit_Based : constant Boolean := Unique_Compile or else not Builder_Data (Tree).Closure_Needed; - -- When Unit_Based is True, put in the queue all compilable - -- sources including the unit based (Ada) one. When Unit_Based is - -- False, put the Ada sources only when they are in a library - -- project. + -- When Unit_Based is True, we enqueue all compilable sources + -- including the unit based (Ada) one. When Unit_Based is False, + -- put the Ada sources only when they are in a library project. - Iter : Source_Iterator; - Source : Prj.Source_Id; + Iter : Source_Iterator; + Source : Prj.Source_Id; + OK : Boolean; + Closure : Boolean; begin -- Nothing to do when "-u" was specified and some files were -- specified on the command line - if Unique_Compile - and then Mains.Number_Of_Mains (Tree) > 0 - then + if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then return; end if; @@ -2950,16 +2951,13 @@ package body Makeutl is if Is_Allowed_Language (Source.Language.Name) and then Is_Compilable (Source) - and then - (All_Projects - or else Is_Extending (Project, Source.Project)) + and then (All_Projects + or else Is_Extending (Project, Source.Project)) and then not Source.Locally_Removed and then Source.Replaced_By = No_Source - and then - (not Source.Project.Externally_Built - or else - (Is_Extending (Project, Source.Project) - and then not Project.Externally_Built)) + and then (not Source.Project.Externally_Built + or else (Is_Extending (Project, Source.Project) + and then not Project.Externally_Built)) and then Source.Kind /= Sep and then Source.Path /= No_Path_Information then @@ -2972,13 +2970,55 @@ package body Makeutl is then if (Unit_Based or else Source.Unit = No_Unit_Index - or else Source.Project.Library) + or else Source.Project.Library + or else Context.In_Aggregate_Lib + or else Project.Qualifier = Aggregate_Library) and then not Is_Subunit (Source) then - Queue.Insert - (Source => (Format => Format_Gprbuild, - Tree => Tree, - Id => Source)); + OK := True; + Closure := False; + + if Source.Unit /= No_Unit_Index + and then + (Source.Project.Library + or else Project.Qualifier = Aggregate_Library + or else Context.In_Aggregate_Lib) + and then Source.Project.Standalone_Library /= No + then + -- Check if the unit is in the interface + + OK := False; + + declare + List : String_List_Id; + Element : String_Element; + + begin + List := Source.Project.Lib_Interface_ALIs; + while List /= Nil_String loop + Element := + Project_Tree.Shared.String_Elements.Table + (List); + + if Element.Value = Name_Id (Source.Dep_Name) + then + OK := True; + Closure := True; + exit; + end if; + + List := Element.Next; + end loop; + end; + end if; + + if OK then + Queue.Insert + (Source => (Format => Format_Gprbuild, + Tree => Tree, + Id => Source, + Closure => Closure)); + end if; end if; end if; end if; @@ -2987,7 +3027,8 @@ package body Makeutl is end loop; end Do_Insert; - procedure Insert_All is new For_Project_And_Aggregated (Do_Insert); + procedure Insert_All is + new For_Project_And_Aggregated_Context (Do_Insert); begin Insert_All (Project, Project_Tree); @@ -3068,9 +3109,10 @@ package body Makeutl is or else Src_Id.Project.Library_Kind = Static) then Queue.Insert - (Source => (Format => Format_Gprbuild, - Tree => Project_Tree, - Id => Src_Id)); + (Source => (Format => Format_Gprbuild, + Tree => Project_Tree, + Id => Src_Id, + Closure => True)); end if; end if; end loop; @@ -3155,7 +3197,10 @@ package body Makeutl is Data.Need_Linking := False; else - Data.Closure_Needed := Has_Mains; + Data.Closure_Needed := + Has_Mains + or else (Root_Project.Library + and then Root_Project.Standalone_Library /= No); Data.Need_Compilation := All_Phases or Option_Compile_Only; Data.Need_Binding := All_Phases or Option_Bind_Only; Data.Need_Linking := (All_Phases or Option_Link_Only) diff --git a/main/gcc/ada/makeutl.ads b/main/gcc/ada/makeutl.ads index 370f32ae14e..04537090318 100644 --- a/main/gcc/ada/makeutl.ads +++ b/main/gcc/ada/makeutl.ads @@ -79,6 +79,16 @@ package Makeutl is Create_Map_File_Switch : constant String := "--create-map-file"; -- Switch to create a map file when an executable is linked + No_Exit_Message_Option : constant String := "--no-exit-message"; + -- Switch to suppress exit error message when there are compilation + -- failures. This is useful when a tool, such as gnatprove, silently calls + -- the builder and does not want to pollute its output with error messages + -- coming from the builder. This is an internal switch. + + Keep_Temp_Files_Option : constant String := "--keep-temp-files"; + -- Switch to suppress deletion of temp files created by the builder. + -- Note that debug switch -gnatdn also has this effect. + Load_Standard_Base : Boolean := True; -- False when gprbuild is called with --db- @@ -489,8 +499,9 @@ package Makeutl is record case Format is when Format_Gprbuild => - Tree : Project_Tree_Ref := No_Project_Tree; - Id : Source_Id := No_Source; + Tree : Project_Tree_Ref := No_Project_Tree; + Id : Source_Id := No_Source; + Closure : Boolean := False; when Format_Gnatmake => File : File_Name_Type := No_File; @@ -504,7 +515,8 @@ package Makeutl is -- depends on the builder, and in particular whether it only supports -- project-based files (in which case we have a full Source_Id record). - No_Source_Info : constant Source_Info := (Format_Gprbuild, null, null); + No_Source_Info : constant Source_Info := + (Format_Gprbuild, null, null, False); procedure Initialize (Queue_Per_Obj_Dir : Boolean; diff --git a/main/gcc/ada/memtrack.adb b/main/gcc/ada/memtrack.adb index 2499bb723e9..869990de95a 100644 --- a/main/gcc/ada/memtrack.adb +++ b/main/gcc/ada/memtrack.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 @@ -- GNU/Linux -- HP-UX -- Solaris --- Alpha OpenVMS -- NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is -- 64 bit. If the need arises to support architectures where this assumption @@ -132,7 +131,7 @@ package body System.Memory is Max_Call_Stack : constant := 200; -- Maximum number of frames supported - Tracebk : aliased array (0 .. Max_Call_Stack) of Traceback_Entry; + Tracebk : Tracebacks_Array (1 .. Max_Call_Stack); Num_Calls : aliased Integer := 0; Gmemfname : constant String := "gmem.out" & ASCII.NUL; @@ -196,8 +195,8 @@ package body System.Memory is end if; Timestamp := System.OS_Primitives.Clock; - Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls, - Skip_Frames => 2); + Call_Chain + (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); fputc (Character'Pos ('A'), Gmemfile); fwrite (Result'Address, Address_Size, 1, Gmemfile); fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, @@ -262,8 +261,8 @@ package body System.Memory is Gmem_Initialize; end if; - Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls, - Skip_Frames => 2); + Call_Chain + (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); Timestamp := System.OS_Primitives.Clock; fputc (Character'Pos ('D'), Gmemfile); fwrite (Addr'Address, Address_Size, 1, Gmemfile); @@ -345,8 +344,8 @@ package body System.Memory is if Needs_Init then Gmem_Initialize; end if; - Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls, - Skip_Frames => 2); + Call_Chain + (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); Timestamp := System.OS_Primitives.Clock; fputc (Character'Pos ('D'), Gmemfile); fwrite (Addr'Address, Address_Size, 1, Gmemfile); diff --git a/main/gcc/ada/mkdir.c b/main/gcc/ada/mkdir.c index b8dba597240..bdb0fa8f7b9 100644 --- a/main/gcc/ada/mkdir.c +++ b/main/gcc/ada/mkdir.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2002-2012, Free Software Foundation, Inc. * + * Copyright (C) 2002-2014, Free Software Foundation, Inc. * * * * GNAT is 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,7 @@ int __gnat_mkdir (char *dir_name, int encoding ATTRIBUTE_UNUSED) { -#if defined (__vxworks) && !(defined (__RTP__) && (_WRS_VXWORKS_MINOR != 0)) +#if defined (__vxworks) && !(defined (__RTP__) && ((_WRS_VXWORKS_MAJOR == 7) || (_WRS_VXWORKS_MINOR != 0))) return mkdir (dir_name); #elif defined (__MINGW32__) TCHAR wname [GNAT_MAX_PATH_LEN + 2]; diff --git a/main/gcc/ada/mlib-prj.adb b/main/gcc/ada/mlib-prj.adb index 945f9137252..943361fbc45 100644 --- a/main/gcc/ada/mlib-prj.adb +++ b/main/gcc/ada/mlib-prj.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, AdaCore -- +-- Copyright (C) 2001-2014, 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- -- @@ -38,7 +38,6 @@ with Sinput.P; with Snames; use Snames; with Switch; use Switch; with Table; -with Targparm; use Targparm; with Tempdir; with Types; use Types; @@ -61,8 +60,8 @@ package body MLib.Prj is ALI_Suffix : constant String := ".ali"; - B_Start : String_Ptr := new String'("b~"); - -- Prefix of bind file, changed to b__ for VMS + B_Start : constant String := "b~"; + -- Prefix of bind file S_Osinte_Ads : File_Name_Type := No_File; -- Name_Id for "s-osinte.ads" @@ -310,9 +309,6 @@ package body MLib.Prj is Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed; -- Set True if library needs to be linked with libgnarl - Libdecgnat_Needed : Boolean := False; - -- On OpenVMS, set True if library needs to be linked with libdecgnat - Object_Directory_Path : constant String := Get_Name_String (For_Project.Object_Directory.Display_Name); @@ -367,9 +363,7 @@ package body MLib.Prj is procedure Check_Libs (ALI_File : String; Main_Project : Boolean); -- Set Libgnarl_Needed if the ALI_File indicates that there is a need -- to link with -lgnarl (this is the case when there is a dependency - -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file - -- indicates that there is a need to link with -ldecgnat (this is the - -- case when there is a dependency on dec.ads). + -- on s-osinte.ads). procedure Process (The_ALI : File_Name_Type); -- Check if the closure of a library unit which is or should be in the @@ -503,11 +497,8 @@ package body MLib.Prj is Id : ALI.ALI_Id; begin - if Libgnarl_Needed /= Yes - or else - (Main_Project - and then OpenVMS_On_Target) - then + if Libgnarl_Needed /= Yes then + -- Scan the ALI file Name_Len := ALI_File'Length; @@ -536,11 +527,6 @@ package body MLib.Prj is else exit; end if; - - elsif OpenVMS_On_Target then - if ALI.Sdep.Table (Index).Sfile = S_Dec_Ads then - Libdecgnat_Needed := True; - end if; end if; end loop; end if; @@ -851,19 +837,14 @@ package body MLib.Prj is Arguments := new String_List (1 .. Initial_Argument_Max); end if; - -- Add "-n -o b~.adb (b__.adb on VMS) -L_" + -- Add "-n -o b~.adb -L_" Argument_Number := 2; Arguments (1) := No_Main; Arguments (2) := Output_Switch; - if OpenVMS_On_Target then - B_Start := new String'("b__"); - end if; - Add_Argument - (B_Start.all - & Get_Name_String (For_Project.Library_Name) & ".adb"); + (B_Start & Get_Name_String (For_Project.Library_Name) & ".adb"); -- Make sure that the init procedure is never "adainit" @@ -1220,13 +1201,8 @@ package body MLib.Prj is Arguments (1) := Compile_Switch; Arguments (2) := No_Warning; - if OpenVMS_On_Target then - B_Start := new String'("b__"); - end if; - Add_Argument - (B_Start.all - & Get_Name_String (For_Project.Library_Name) & ".adb"); + (B_Start & Get_Name_String (For_Project.Library_Name) & ".adb"); -- If necessary, add the PIC option @@ -1429,7 +1405,7 @@ package body MLib.Prj is if In_Main_Object_Directory or else Last < 5 or else - C_Filename (1 .. B_Start'Length) /= B_Start.all + C_Filename (1 .. B_Start'Length) /= B_Start then Name_Len := 0; Add_Str_To_Name_Buffer (C_Filename); @@ -1458,7 +1434,7 @@ package body MLib.Prj is (Last >= 5 and then C_Filename (1 .. B_Start'Length) - = B_Start.all); + = B_Start); if Is_Regular_File (ALI_Path) then @@ -1624,21 +1600,6 @@ package body MLib.Prj is end if; end if; - if Libdecgnat_Needed then - Opts.Increment_Last; - - Opts.Table (Opts.Last) := - new String'("-L" & Lib_Directory & "/../declib"); - - Opts.Increment_Last; - - if The_Build_Mode = Static then - Opts.Table (Opts.Last) := new String'("-ldecgnat"); - else - Opts.Table (Opts.Last) := new String'(Shared_Lib ("decgnat")); - end if; - end if; - Opts.Increment_Last; if The_Build_Mode = Static then @@ -1765,10 +1726,8 @@ package body MLib.Prj is Argument_Number := 0; -- If we have a standalone library, gather all the interface ALI. - -- They are passed to Build_Dynamic_Library, where they are used by - -- some platforms (VMS, for example) to decide what symbols should be - -- exported. They are also flagged as Interface when we copy them to - -- the library directory (by Copy_ALI_Files, below). + -- They are flagged as Interface when we copy them to the library + -- directory (by Copy_ALI_Files, below). if Standalone then Current_Proj := For_Project; @@ -2131,10 +2090,6 @@ package body MLib.Prj is Object_Dir : Dir_Type; begin - if OpenVMS_On_Target then - B_Start := new String'("b__"); - end if; - -- If the library file does not exist, then the time stamp will -- be Empty_Time_Stamp, earlier than any other time stamp. @@ -2152,7 +2107,7 @@ package body MLib.Prj is -- generated file. if Is_Obj (Name_Buffer (1 .. Name_Len)) - and then Name_Buffer (1 .. B_Start'Length) /= B_Start.all + and then Name_Buffer (1 .. B_Start'Length) /= B_Start then -- Get the object file time stamp @@ -2443,9 +2398,8 @@ package body MLib.Prj is -- Also ignore the shared libraries which are : - -- UNIX / Windows VMS - -- -lgnat- -lgnat_ (7 + version'length chars) - -- -lgnarl- -lgnarl_ (8 + version'length chars) + -- -lgnat- (7 + version'length chars) + -- -lgnarl- (8 + version'length chars) if Next_Line (1 .. Nlast) /= "-static" and then Next_Line (1 .. Nlast) /= "-shared" and then diff --git a/main/gcc/ada/mlib-tgt-specific-hpux.adb b/main/gcc/ada/mlib-tgt-specific-hpux.adb index 720b0860adf..57e40841a80 100644 --- a/main/gcc/ada/mlib-tgt-specific-hpux.adb +++ b/main/gcc/ada/mlib-tgt-specific-hpux.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2008, AdaCore -- +-- Copyright (C) 2003-2014, 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- -- @@ -80,11 +80,10 @@ package body MLib.Tgt.Specific is Common_Options : constant Argument_List := Options & new String'(PIC_Option); - -- Common set of options to the gcc command performing the link. - -- On HPUX, this command eventually resorts to collect2, which may - -- generate a C file and compile it on the fly. This compilation shall - -- also generate position independent code for the final link to - -- succeed. + -- Common set of options to the gcc command performing the link. On + -- HPUX, this command eventually resorts to collect2, which may generate + -- a C file and compile it on the fly. This compilation also generates + -- position independent code for the final link to succeed. begin if Opt.Verbose_Mode then Write_Str ("building relocatable shared library "); diff --git a/main/gcc/ada/mlib-tgt-specific-vms-alpha.adb b/main/gcc/ada/mlib-tgt-specific-vms-alpha.adb deleted file mode 100644 index 082cbbebcd4..00000000000 --- a/main/gcc/ada/mlib-tgt-specific-vms-alpha.adb +++ /dev/null @@ -1,509 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . S P E C I F I C -- --- (Alpha VMS Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha VMS version of the body - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -with MLib.Fil; -with MLib.Utl; - -with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common; - -with Opt; use Opt; -with Output; use Output; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System; use System; -with System.Case_Util; use System.Case_Util; -with System.CRTL; use System.CRTL; - -package body MLib.Tgt.Specific is - - -- Non default subprogram. See comment in mlib-tgt.ads - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - -- Local variables - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Libgcc_Switch : constant Argument_List := - (1 => Shared_Libgcc'Access); - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. For other libraries, always - -- return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is - -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy - -- is Autonomous, fails gnatmake if Lib_Version is not the image of a - -- positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 2) = "b__" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Path then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - - begin - if Lib_Version = "" - or else Symbol_Data.Symbol_Policy /= Autonomous - then - return ""; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """ - & Lib_Version - & """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - --------------------- - -- Local Variables -- - --------------------- - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- If option file name does not ends with ".opt", append "/OPTIONS" - -- to its specification for the VMS linker. - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - For_Linker_Opt := - new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name & " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "__init.asm"; - Macro_File : File_Descriptor; - Init_Proc : constant String := Init_Proc_Name (Lib_Filename); - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - - mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - - begin - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - use ASCII; - - -- Output a dummy transfer address for debugging - -- followed by the LIB$INITIALIZE section. - - Lines : constant String := - HT & ".text" & LF & - HT & ".align 4" & LF & - HT & ".globl __main" & LF & - HT & ".ent __main" & LF & - "__main..en:" & LF & - HT & ".base $27" & LF & - HT & ".frame $29,0,$26,8" & LF & - HT & "ret $31,($26),1" & LF & - HT & ".link" & LF & - "__main:" & LF & - HT & ".pdesc __main..en,null" & LF & - HT & ".end __main" & LF & LF & - HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF & - HT & ".long " & Init_Proc & LF; - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, Lines (Lines'First)'Address, - Lines'Length); - OK := Len = Lines'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := popen (command (command'First)'Address, - mode (mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "__init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Path then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - - when Restricted => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-R"); - - when Direct => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-D"); - - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """ - & Lib_Filename - & """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Shared_Libgcc_Switch & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "__init.obj"; - Disregard : Boolean; - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - --- Package initialization - -begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; -end MLib.Tgt.Specific; diff --git a/main/gcc/ada/mlib-tgt-specific-vms-ia64.adb b/main/gcc/ada/mlib-tgt-specific-vms-ia64.adb deleted file mode 100644 index c2958586097..00000000000 --- a/main/gcc/ada/mlib-tgt-specific-vms-ia64.adb +++ /dev/null @@ -1,513 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . S P E C I F I C -- --- (Integrity VMS Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Integrity VMS version of the body - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -with MLib.Fil; -with MLib.Utl; - -with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common; - -with Opt; use Opt; -with Output; use Output; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System; use System; -with System.Case_Util; use System.Case_Util; -with System.CRTL; use System.CRTL; - -package body MLib.Tgt.Specific is - - -- Non default subprogram, see comment in mlib-tgt.ads - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - -- Local variables - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Libgcc_Switch : constant Argument_List := - (1 => Shared_Libgcc'Access); - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. For other libraries, always - -- return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is - -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy - -- is Autonomous, fails gnatmake if Lib_Version is not the image of a - -- positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 2) = "b__" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Path then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - begin - if Lib_Version = "" - or else Symbol_Data.Symbol_Policy /= Autonomous - then - return ""; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """ - & Lib_Version - & """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - --------------------- - -- Local Variables -- - --------------------- - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- Option file must end with ".opt" - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - Fail ("Options File """ & Opt_File_Name & """ must end with .opt"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name & " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "__init.asm"; - Macro_File : File_Descriptor; - Init_Proc : constant String := Init_Proc_Name (Lib_Filename); - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - -- Why odd lower case name ??? - - mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - -- Why odd lower case name ??? - - begin - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - use ASCII; - - -- Output a dummy transfer address for debugging - -- followed by the LIB$INITIALIZE section. - - Lines : constant String := - HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF & - HT & ".text" & LF & - HT & ".align 16" & LF & - HT & ".global __main#" & LF & - HT & ".proc __main#" & LF & - "__main:" & LF & - HT & ".prologue" & LF & - HT & ".body" & LF & - HT & ".mib" & LF & - HT & "nop 0" & LF & - HT & "nop 0" & LF & - HT & "br.ret.sptk.many b0" & LF & - HT & ".endp __main#" & LF & LF & - HT & ".type " & Init_Proc & "#, @function" & LF & - HT & ".global " & Init_Proc & "#" & LF & - HT & ".global LIB$INITIALIZE#" & LF & - HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF & - HT & "data4 @fptr(" & Init_Proc & "#)" & LF; - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, Lines (Lines'First)'Address, - Lines'Length); - OK := Len = Lines'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := popen (command (command'First)'Address, - mode (mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "__init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Path then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - - when Restricted => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-R"); - - when Direct => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-D"); - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """ - & Lib_Filename - & """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Shared_Libgcc_Switch & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "__init.obj"; - - Disregard : Boolean; - pragma Warnings (Off, Disregard); - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - --- Package initialization - -begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; -end MLib.Tgt.Specific; diff --git a/main/gcc/ada/mlib-tgt-vms_common.adb b/main/gcc/ada/mlib-tgt-vms_common.adb deleted file mode 100644 index 53db3a887d4..00000000000 --- a/main/gcc/ada/mlib-tgt-vms_common.adb +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . V M S _ C O M M O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the part of MLib.Tgt.Specific common to both VMS versions - -with System.Case_Util; use System.Case_Util; - -package body MLib.Tgt.VMS_Common is - - -- Non default subprograms. See comments in mlib-tgt.ads - - function Archive_Ext return String; - - function Default_Symbol_File_Name return String; - - function DLL_Ext return String; - - function Is_Object_Ext (Ext : String) return Boolean; - - function Is_Archive_Ext (Ext : String) return Boolean; - - function Libgnat return String; - - function Object_Ext return String; - - function Library_Major_Minor_Id_Supported return Boolean; - - function PIC_Option return String; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "olb"; - end Archive_Ext; - - ------------------------------ - -- Default_Symbol_File_Name -- - ------------------------------ - - function Default_Symbol_File_Name return String is - begin - return "symvec.opt"; - end Default_Symbol_File_Name; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "exe"; - end DLL_Ext; - - -------------------- - -- Init_Proc_Name -- - -------------------- - - function Init_Proc_Name (Library_Name : String) return String is - Result : String := Library_Name & "INIT"; - begin - To_Upper (Result); - - if Result = "ADAINIT" then - return "ADA_INIT"; - - else - return Result; - end if; - end Init_Proc_Name; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".obj"; - end Is_Object_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".olb" or else Ext = ".exe"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - Libgnat_A : constant String := "libgnat.a"; - Libgnat_Olb : constant String := "libgnat.olb"; - - begin - Name_Len := Libgnat_A'Length; - Name_Buffer (1 .. Name_Len) := Libgnat_A; - - if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then - return Libgnat_A; - else - return Libgnat_Olb; - end if; - end Libgnat; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "obj"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - --- Package initialization - -begin - Archive_Ext_Ptr := Archive_Ext'Access; - Default_Symbol_File_Name_Ptr := Default_Symbol_File_Name'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Is_Object_Ext_Ptr := Is_Object_Ext'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - Libgnat_Ptr := Libgnat'Access; - Object_Ext_Ptr := Object_Ext'Access; - PIC_Option_Ptr := PIC_Option'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - -end MLib.Tgt.VMS_Common; diff --git a/main/gcc/ada/mlib-tgt-vms_common.ads b/main/gcc/ada/mlib-tgt-vms_common.ads deleted file mode 100644 index 7a4fbb88278..00000000000 --- a/main/gcc/ada/mlib-tgt-vms_common.ads +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . V M S _ C O M M O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the part of MLib.Tgt.Specific common to both VMS versions - -package MLib.Tgt.VMS_Common is - pragma Elaborate_Body; - - function Init_Proc_Name (Library_Name : String) return String; - -- Returns, in upper case, Library_Name & "INIT", except when Library_Name - -- is "ada" (case insensitive), returns "ADA_INIT". - -end MLib.Tgt.VMS_Common; diff --git a/main/gcc/ada/mlib-tgt.ads b/main/gcc/ada/mlib-tgt.ads index cbb15d3ac1d..0260159bfeb 100644 --- a/main/gcc/ada/mlib-tgt.ads +++ b/main/gcc/ada/mlib-tgt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, AdaCore -- +-- Copyright (C) 2001-2014, 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- -- @@ -132,8 +132,8 @@ package MLib.Tgt is -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which -- will be the actual library file. -- - -- Symbol_Data is used for some platforms, including VMS, to generate - -- the symbols to be exported by the library. + -- Symbol_Data is used for some platforms, to generate the symbols to be + -- exported by the library (not certain if it is currently in use or not). -- -- Note: Depending on the OS, some of the parameters may not be taken into -- account. For example, on Linux, Interfaces, Symbol_Data and Auto_Init diff --git a/main/gcc/ada/mlib.adb b/main/gcc/ada/mlib.adb index 4c4d375f324..c4faea0e4a1 100644 --- a/main/gcc/ada/mlib.adb +++ b/main/gcc/ada/mlib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -27,7 +27,6 @@ with Ada.Characters.Handling; use Ada.Characters.Handling; with Interfaces.C.Strings; with System; -with Hostparm; with Opt; with Output; use Output; @@ -206,8 +205,11 @@ package body MLib is S := new String (1 .. Len + 3); - -- Read the file. Note that the loop is not necessary - -- since the whole file is read at once except on VMS. + -- Read the file. This loop is probably not necessary + -- since on most (all?) targets, the whole file is + -- read in at once, but we have encountered systems + -- in the past where this was not true, and we retain + -- this loop in case we encounter that in the future. Curr := S'First; while Curr <= Len loop @@ -459,12 +461,4 @@ package body MLib is return Separate_Paths; end Separate_Run_Path_Options; --- Package elaboration - -begin - -- Copy_Attributes always fails on VMS - - if Hostparm.OpenVMS then - Preserve := None; - end if; end MLib; diff --git a/main/gcc/ada/mlib.ads b/main/gcc/ada/mlib.ads index 0aa62d21574..e370fa48de9 100644 --- a/main/gcc/ada/mlib.ads +++ b/main/gcc/ada/mlib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2009, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -89,9 +89,7 @@ package MLib is -- for each directory in the rpath. private - Preserve : Attribute := Time_Stamps; - -- Used by Copy_ALI_Files. Changed to None for OpenVMS, because - -- Copy_Attributes always fails on VMS. + -- Used by Copy_ALI_Files end MLib; diff --git a/main/gcc/ada/namet.h b/main/gcc/ada/namet.h index 0bc841ac85d..1ca589ba50c 100644 --- a/main/gcc/ada/namet.h +++ b/main/gcc/ada/namet.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, Free Software Foundation, Inc. * * * * GNAT is 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,9 +109,6 @@ extern char *Spec_Context_List, *Body_Context_List; #define Body_Filename exp_dbug__body_filename extern char *Spec_Filename, *Body_Filename; -#define Is_Non_Ada_Error exp_ch11__is_non_ada_error -extern Boolean Is_Non_Ada_Error (Entity_Id); - /* Here are some functions in sinput.adb we call from trans.c. */ typedef Nat Source_File_Index; diff --git a/main/gcc/ada/nlists.adb b/main/gcc/ada/nlists.adb index 41b5ac2e08c..dcb5dd41cb7 100644 --- a/main/gcc/ada/nlists.adb +++ b/main/gcc/ada/nlists.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -744,8 +744,8 @@ package body Nlists is else NL := New_List; - E := First (List); + E := First (List); while Present (E) loop if Comes_From_Source (E) then Append (New_Copy (E), NL); diff --git a/main/gcc/ada/nlists.ads b/main/gcc/ada/nlists.ads index 42c280e2331..5950b4a71ab 100644 --- a/main/gcc/ada/nlists.ads +++ b/main/gcc/ada/nlists.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 @@ package Nlists is -- No_List. (No_List is not considered to be the same as an empty list). function List_Length (List : List_Id) return Nat; - pragma Inline (List_Length); -- Returns number of items in the given list. It is an error to call -- this function with No_List (No_List is not considered to be the same -- as an empty list). @@ -226,9 +225,9 @@ package Nlists is procedure Append (Node : Node_Or_Entity_Id; To : List_Id); -- Appends Node at the end of node list To. Node must be a non-empty node - -- that is not already a member of a node list, and To must be a - -- node list. An attempt to append an error node is ignored without - -- complaint and the list is unchanged. + -- that is not already a member of a node list, and To must be a node list. + -- An attempt to append an error node is ignored without complaint and the + -- list is unchanged. procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id); pragma Inline (Append_To); diff --git a/main/gcc/ada/opt.adb b/main/gcc/ada/opt.adb index c8edad417ce..4144340c47a 100644 --- a/main/gcc/ada/opt.adb +++ b/main/gcc/ada/opt.adb @@ -52,6 +52,7 @@ package body Opt is Check_Float_Overflow_Config := Check_Float_Overflow; Check_Policy_List_Config := Check_Policy_List; Default_Pool_Config := Default_Pool; + Default_SSO_Config := Default_SSO; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; Extensions_Allowed_Config := Extensions_Allowed; @@ -62,9 +63,9 @@ package body Opt is Optimize_Alignment_Config := Optimize_Alignment; Persistent_BSS_Mode_Config := Persistent_BSS_Mode; Polling_Required_Config := Polling_Required; - Short_Descriptors_Config := Short_Descriptors; SPARK_Mode_Config := SPARK_Mode; SPARK_Mode_Pragma_Config := SPARK_Mode_Pragma; + Uneval_Old_Config := Uneval_Old; Use_VADS_Size_Config := Use_VADS_Size; Warnings_As_Errors_Count_Config := Warnings_As_Errors_Count; @@ -89,6 +90,7 @@ package body Opt is Check_Float_Overflow := Save.Check_Float_Overflow; Check_Policy_List := Save.Check_Policy_List; Default_Pool := Save.Default_Pool; + Default_SSO := Save.Default_SSO; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; Extensions_Allowed := Save.Extensions_Allowed; @@ -100,9 +102,9 @@ package body Opt is Optimize_Alignment_Local := Save.Optimize_Alignment_Local; Persistent_BSS_Mode := Save.Persistent_BSS_Mode; Polling_Required := Save.Polling_Required; - Short_Descriptors := Save.Short_Descriptors; SPARK_Mode := Save.SPARK_Mode; SPARK_Mode_Pragma := Save.SPARK_Mode_Pragma; + Uneval_Old := Save.Uneval_Old; Use_VADS_Size := Save.Use_VADS_Size; Warnings_As_Errors_Count := Save.Warnings_As_Errors_Count; @@ -128,6 +130,7 @@ package body Opt is Save.Check_Float_Overflow := Check_Float_Overflow; Save.Check_Policy_List := Check_Policy_List; Save.Default_Pool := Default_Pool; + Save.Default_SSO := Default_SSO; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; Save.Extensions_Allowed := Extensions_Allowed; @@ -139,9 +142,9 @@ package body Opt is Save.Optimize_Alignment_Local := Optimize_Alignment_Local; Save.Persistent_BSS_Mode := Persistent_BSS_Mode; Save.Polling_Required := Polling_Required; - Save.Short_Descriptors := Short_Descriptors; Save.SPARK_Mode := SPARK_Mode; Save.SPARK_Mode_Pragma := SPARK_Mode_Pragma; + Save.Uneval_Old := Uneval_Old; Save.Use_VADS_Size := Use_VADS_Size; Save.Warnings_As_Errors_Count := Warnings_As_Errors_Count; end Save_Opt_Config_Switches; @@ -171,6 +174,7 @@ package body Opt is External_Name_Imp_Casing := Lowercase; Optimize_Alignment := 'O'; Persistent_BSS_Mode := False; + Uneval_Old := 'E'; Use_VADS_Size := False; Optimize_Alignment_Local := True; @@ -186,6 +190,7 @@ package body Opt is Assertions_Enabled := Assertions_Enabled_Config; Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; Check_Policy_List := Check_Policy_List_Config; + Default_SSO := Default_SSO_Config; SPARK_Mode := SPARK_Mode_Config; SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config; else @@ -206,6 +211,7 @@ package body Opt is Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config; Check_Float_Overflow := Check_Float_Overflow_Config; Check_Policy_List := Check_Policy_List_Config; + Default_SSO := Default_SSO_Config; Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; Extensions_Allowed := Extensions_Allowed_Config; External_Name_Exp_Casing := External_Name_Exp_Casing_Config; @@ -217,6 +223,7 @@ package body Opt is Persistent_BSS_Mode := Persistent_BSS_Mode_Config; SPARK_Mode := SPARK_Mode_Config; SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config; + Uneval_Old := Uneval_Old_Config; Use_VADS_Size := Use_VADS_Size_Config; Warnings_As_Errors_Count := Warnings_As_Errors_Count_Config; @@ -234,7 +241,6 @@ package body Opt is Fast_Math := Fast_Math_Config; Optimize_Alignment := Optimize_Alignment_Config; Polling_Required := Polling_Required_Config; - Short_Descriptors := Short_Descriptors_Config; end Set_Opt_Config_Switches; --------------- diff --git a/main/gcc/ada/opt.ads b/main/gcc/ada/opt.ads index 59737769468..2e00d4aa995 100644 --- a/main/gcc/ada/opt.ads +++ b/main/gcc/ada/opt.ads @@ -224,7 +224,7 @@ package Opt is -- GNAT Normally, in accordance with (RM 13.9.1 (9-11)) the front end -- assumes that values could have invalid representations, unless it can -- clearly prove that the values are valid. If this switch is set (by - -- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values + -- pragma Assume_No_Invalid_Values (On)), then the compiler assumes values -- are valid and in range of their representations. This feature is now -- fully enabled in the compiler. @@ -246,6 +246,13 @@ package Opt is -- default can be modified using -gnatd.L (sets the flag True). This is -- used to test the possibility of having the backend handle this. + Back_End_Inlining : Boolean := False; + -- GNAT + -- Set True to activate inlining by back-end expansion. This is the normal + -- default mode for gcc targets, so it is True on such targets unless the + -- switches -gnatN or -gnatd.z are used. See circuitry in gnat1drv for the + -- exact conditions for setting this switch. + Bind_Alternate_Main_Name : Boolean := False; -- GNATBIND -- True if main should be called Alternate_Main_Name.all. @@ -366,14 +373,17 @@ package Opt is -- True if source lines removed by the preprocessor should be commented -- in the output file. + Compilation_Time : String (1 .. 19); + -- GNAT + -- Compilation date and time in form YYYY-MM-DD HH:MM:SS + Compile_Only : Boolean := False; -- GNATMAKE, GNATCLEAN, GPRMAKE, GPBUILD, GPRCLEAN -- GNATMAKE, GPRMAKE, GPRMAKE: - -- set to True to skip bind and link steps (except when Bind_Only is - -- True). + -- set True to skip bind and link steps (except when Bind_Only is True) -- GNATCLEAN, GPRCLEAN: - -- set to True to delete only the files produced by the compiler but not - -- the library files or the executable files. + -- set True to delete only the files produced by the compiler but not the + -- library files or the executable files. Compiler_Unit : Boolean := False; -- GNAT1 @@ -411,12 +421,14 @@ package Opt is subtype Debug_Level_Value is Nat range 0 .. 3; Debugger_Level : Debug_Level_Value := 0; - -- GNATBIND -- The value given to the -g parameter. The default value for -g with - -- no value is 2. This is usually ignored by GNATBIND, except in the - -- VMS version where it is passed as an argument to __gnat_initialize - -- to trigger the activation of the remote debugging interface. - -- Is this still true ??? + -- no value is 2. This is not currently used but is retained for possible + -- future use. + + Default_Exit_Status : Int := 0; + -- GNATBIND + -- Set the default exit status value. Set by the -Xnnn switch for the + -- binder. Debug_Generated_Code : Boolean := False; -- GNAT @@ -424,11 +436,15 @@ package Opt is -- of the original source code. Causes debugging information to be -- written with respect to the generated code file that is written. - Default_Exit_Status : Int := 0; - -- GNATBIND - -- Set the default exit status value. Set by the -Xnnn switch for the - -- binder. - + Default_Pool : Node_Id := Empty; + -- GNAT + -- Used to record the storage pool name (or null literal) that is the + -- argument of an applicable pragma Default_Storage_Pool. + -- Empty: No pragma Default_Storage_Pool applies. + -- N_Null node: "pragma Default_Storage_Pool (null);" applies. + -- otherwise: "pragma Default_Storage_Pool (X);" applies, and + -- this points to the name X. + -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value. Default_Stack_Size : Int := -1; -- GNATBIND -- Set to default primary stack size in units of bytes. Set by @@ -442,15 +458,11 @@ package Opt is -- default was set by the binder, and that the default should be the -- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size. - Default_Pool : Node_Id := Empty; + Default_SSO : Character := ' '; -- GNAT - -- Used to record the storage pool name (or null literal) that is the - -- argument of an applicable pragma Default_Storage_Pool. - -- Empty: No pragma Default_Storage_Pool applies. - -- N_Null node: "pragma Default_Storage_Pool (null);" applies. - -- otherwise: "pragma Default_Storage_Pool (X);" applies, and - -- this points to the name X. - -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value. + -- Set if a pragma Default_Scalar_Storage_Order has been given. The value + -- of ' ' indicates that no default has been set, otherwise the value is + -- either 'H' for High_Order_First or 'L' for Lower_Order_First. Detect_Blocking : Boolean := False; -- GNAT @@ -627,19 +639,6 @@ package Opt is -- Indicates the current setting of Fast_Math mode, as set by the use -- of a Fast_Math pragma (set True by Fast_Math (On)). - Float_Format : Character := ' '; - -- GNAT - -- A non-blank value indicates that a Float_Format pragma has been - -- processed, in which case this variable is set to 'I' for IEEE or to - -- 'V' for VAX. The setting of 'V' is only possible on OpenVMS versions - -- of GNAT. - - Float_Format_Long : Character := ' '; - -- GNAT - -- A non-blank value indicates that a Long_Float pragma has been processed - -- (this pragma is recognized only in OpenVMS versions of GNAT), in which - -- case this variable is set to D or G for D_Float or G_Float. - Force_ALI_Tree_File : Boolean := False; -- GNAT -- Force generation of ALI file even if errors are encountered. Also forces @@ -649,6 +648,20 @@ package Opt is -- GNAT -- Disable generation of ALI file + Follow_Links_For_Files : Boolean := False; + -- PROJECT MANAGER + -- Set to True (-eL) to process the project files in trusted mode. If + -- Follow_Links is False, it is assumed that the project doesn't contain + -- any file duplicated through symbolic links (although the latter are + -- still valid if they point to a file which is outside of the project), + -- and that no directory has a name which is a valid source name. + + Follow_Links_For_Dirs : Boolean := False; + -- PROJECT MANAGER + -- Set to True if directories can be links in this project, and therefore + -- additional system calls must be performed to ensure that we always see + -- the same full name for each directory. + Force_Checking_Of_Elaboration_Flags : Boolean := False; -- GNATBIND -- True if binding with forced checking of the elaboration flags @@ -658,6 +671,13 @@ package Opt is -- GNATMAKE, GPRMAKE, GPRBUILD -- Set to force recompilations even when the objects are up-to-date. + Front_End_Inlining : Boolean := False; + -- GNAT + -- Set True to activate inlining by front-end expansion (even on GCC + -- targets, where inlining is normally handled by the back end). Set by + -- the flag -gnatN (which is now considered obsolescent, since the GCC + -- back end can do a better job of inlining than the front end these days. + Full_Path_Name_For_Brief_Errors : Boolean := False; -- PROJECT MANAGER -- When True, in Brief_Output mode, each error message line @@ -685,6 +705,10 @@ package Opt is -- True when switch -gnateG is used. When True, create in a file -- .prep, if the source is preprocessed. + Generate_SCIL : Boolean := False; + -- GNAT + -- Set True to activate SCIL code generation. + Generate_SCO : Boolean := False; -- GNAT -- True when switch -fdump-scos (or -gnateS) is used. When True, Source @@ -706,15 +730,6 @@ package Opt is -- True if a pragma Discard_Names appeared as a configuration pragma for -- the current compilation unit. - GNAT_Mode : Boolean := False; - -- GNAT - -- True if compiling in GNAT system mode (-gnatg switch) - - Heap_Size : Nat := 0; - -- GNATBIND - -- Heap size for memory allocations. Valid values are 32 and 64. Only - -- available on VMS. - Identifier_Character_Set : Character; -- GNAT -- This variable indicates the character set to be used for identifiers. @@ -738,6 +753,12 @@ package Opt is -- default value appropriate to the system (in Osint.Initialize), and then -- reset if a command line switch is used to change the setting. + Ignore_Pragma_SPARK_Mode : Boolean := False; + -- GNAT + -- Set True to ignore the semantics and effects of pragma SPARK_Mode when + -- the pragma appears inside an instance whose enclosing context is subject + -- to SPARK_Mode "off". + Ignore_Rep_Clauses : Boolean := False; -- GNAT -- Set True to ignore all representation clauses. Useful when compiling @@ -768,9 +789,11 @@ package Opt is Ineffective_Inline_Warnings : Boolean := False; -- GNAT - -- Set True to activate warnings if front-end inlining (-gnatN) is not - -- able to actually inline a particular call (or all calls). Can be - -- controlled by use of -gnatwp/-gnatwP. + -- Set True to activate warnings if front-end inlining (-gnatN) is not able + -- to actually inline a particular call (or all calls). Can be controlled + -- by use of -gnatwp/-gnatwP. Also set True to activate warnings if + -- frontend inlining is not able to inline a subprogram expected to + -- be inlined in GNATprove mode. Init_Or_Norm_Scalars : Boolean := False; -- GNAT, GANTBIND @@ -806,32 +829,10 @@ package Opt is -- then elaboration flag checks are to be generated in the binder -- generated file. - Generate_SCIL : Boolean := False; - -- GNAT - -- Set True to activate SCIL code generation. - Invalid_Value_Used : Boolean := False; -- GNAT -- Set True if a valid Invalid_Value attribute is encountered - Follow_Links_For_Files : Boolean := False; - -- PROJECT MANAGER - -- Set to True (-eL) to process the project files in trusted mode. If - -- Follow_Links is False, it is assumed that the project doesn't contain - -- any file duplicated through symbolic links (although the latter are - -- still valid if they point to a file which is outside of the project), - -- and that no directory has a name which is a valid source name. - - Follow_Links_For_Dirs : Boolean := False; - -- PROJECT MANAGER - -- Set to True if directories can be links in this project, and therefore - -- additional system calls must be performed to ensure that we always see - -- the same full name for each directory. - - Front_End_Inlining : Boolean := False; - -- GNAT - -- Set True to activate inlining by front-end expansion - Inline_Processing_Required : Boolean := False; -- GNAT -- Set True if inline processing is required. Inline processing is required @@ -850,9 +851,9 @@ package Opt is -- sources until there is no more work. Keep_Temporary_Files : Boolean := False; - -- GNATCMD - -- When True the temporary files created by the GNAT driver are not - -- deleted. Set by switch -dn or qualifier /KEEP_TEMPORARY_FILES. + -- GNATCMD, GNATMAKE, GPRBUILD + -- When True the temporary files are not deleted. Set by switches -dn or + -- --keep-temp-files. Leap_Seconds_Support : Boolean := False; -- GNATBIND @@ -1043,6 +1044,11 @@ package Opt is -- Undefined_Symbols_Are_False. Useful to perform a syntax check on all -- branches of #if constructs. + No_Elab_Code_All_Pragma : Node_Id := Empty; + -- Set to point to a No_Elaboration_Code_All pragma or aspect encountered + -- in the spec of the extended main unit. Used to determine if we need to + -- do special tests for violation of this aspect. + No_Main_Subprogram : Boolean := False; -- GNATMAKE, GNATBIND -- Set to True if compilation/binding of a program without main @@ -1290,10 +1296,6 @@ package Opt is -- GNAT -- Set True if a pragma Short_Circuit_And_Or applies to the current unit. - Short_Descriptors : Boolean := False; - -- GNAT - -- Set True if a pragma Short_Descriptors applies to the current unit. - type SPARK_Mode_Type is (None, Off, On); -- Possible legal modes that can be set by aspect/pragma SPARK_Mode, as -- well as the value None, which indicates no such pragma/aspect applies. @@ -1462,12 +1464,6 @@ package Opt is -- GNAT -- Set to True (-gnatt) to generate output tree file - True_VMS_Target : Boolean := False; - -- Set True if we are on a VMS target. The setting of this flag reflects - -- the true state of the compile, unlike Targparm.OpenVMS_On_Target which - -- can also be true when debug flag m is set (-gnatdm). This is used in the - -- few cases where we do NOT want -gnatdm to trigger the VMS behavior. - Try_Semantics : Boolean := False; -- GNAT -- Flag set to force attempt at semantic analysis, even if parser errors @@ -1487,6 +1483,12 @@ package Opt is -- file for the compiler. Indicates that while preprocessing sources, -- symbols that are not defined have the value FALSE. + Uneval_Old : Character := 'E'; + -- GNAT + -- Set to 'E'/'W'/'A' for use of Error/Warn/Allow in a valid pragma + -- Unevaluated_Use_Of_Old. Default in the absence of the pragma is 'E' + -- for the RM default behavior of giving an error. + Unique_Error_Tag : Boolean := Tag_Errors; -- GNAT -- Indicates if error messages are to be prefixed by the string error: @@ -1804,7 +1806,8 @@ package Opt is -- These are settings that are used to establish the mode at the start of -- each unit. The values defined below can be affected either by command -- line switches, or by the use of appropriate configuration pragmas in a - -- configuration pragma file. + -- configuration pragma file (but NOT by a local use of a configuration + -- pragma in a single file). Ada_Version_Config : Ada_Version_Type; -- GNAT @@ -1858,6 +1861,12 @@ package Opt is -- Same as Default_Pool above, except this is only for Default_Storage_Pool -- pragmas that are configuration pragmas. + Default_SSO_Config : Character := ' '; + -- GNAT + -- Set if a pragma Default_Scalar_Storage_Order appears as a configuration + -- pragma. A value of ' ' means that no pragma was given, otherwise the + -- value is 'H' for High_Order_First or 'L' for Low_Order_First. + Dynamic_Elaboration_Checks_Config : Boolean := False; -- GNAT -- Set True for dynamic elaboration checking mode, as set by the -gnatE @@ -1911,6 +1920,11 @@ package Opt is -- This switch is not set when the pragma appears ahead of a given -- unit, so it does not affect the compilation of other units. + No_Exit_Message : Boolean := False; + -- GNATMAKE, GPRBUILD + -- Set with switch --no-exit-message. When True, if there are compilation + -- failures, the builder does not issue an exit error message. + Optimize_Alignment_Config : Character; -- GNAT -- This is the value of the configuration switch that controls the @@ -1936,14 +1950,6 @@ package Opt is -- flag is used to set the initial value for Polling_Required at the start -- of analyzing each unit. - Short_Descriptors_Config : Boolean; - -- GNAT - -- This is the value of the configuration switch that controls the use of - -- Short_Descriptors for setting descriptor default sizes. It can be set - -- True by the use of the pragma Short_Descriptors in the gnat.adc file. - -- This flag is used to set the initial value for Short_Descriptors at the - -- start of analyzing each unit. - SPARK_Mode_Config : SPARK_Mode_Type := None; -- GNAT -- The setting of SPARK_Mode from configuration pragmas @@ -1952,6 +1958,10 @@ package Opt is -- If a SPARK_Mode pragma appeared in the configuration pragmas (setting -- SPARK_Mode_Config appropriately), then this points to the N_Pragma node. + Uneval_Old_Config : Character; + -- GNAT + -- The setting of Uneval_Old from configuration pragmas + Use_VADS_Size_Config : Boolean; -- GNAT -- This is the value of the configuration switch that controls the use of @@ -2085,6 +2095,73 @@ package Opt is -- appropriately licensed unit to declare this as a Table failed with -- various elaboration circularities. Memory is getting cheap these days! + --------------- + -- GNAT_Mode -- + --------------- + + GNAT_Mode : Boolean := False; + -- GNAT + -- True if compiling in GNAT system mode (-gnatg switch) + + -- Setting this switch has the following effects on the language that is + -- accepted. Note that several of the following have the effect of changing + -- an error to a warning. But warnings are usually treated as fatal errors + -- in -gnatg mode, so to actually take advantage of such a change, it is + -- necessary to add an explicit pragma Warnings (Off) in the source and + -- this requires clear documentation of why this is necessary. + + -- The identifier character set is set to 'n' (7-bit ASCII) + + -- Pragma Extend_System is ignored + + -- Warning_Mode is set to Treat_As_Error (-gnatwe) + + -- Standard style checks are set (See Set_GNAT_Style_Check_Options) + + -- Standard warnings are turned on (see Set_GNAT_Mode_Warnings) + + -- The Ada version is set to Ada 2012 + + -- Task priorities are always allowed to be in the range Any_Priority + + -- Overflow checks are suppressed, overflow checking set to strict mode + + -- ALI files are always generated for predefined generic packages + + -- Obsolescent feature warnings are suppressed + + -- Recompilation of children of GNAT, System, Ada, Interfaces is allowed + + -- The Scalar_Storage_Order attribute applies to generic types + + -- Categorization errors are treated as warnings rather than errors + + -- Statements in preelaborated units give warnings rather than errors + + -- Private objects are allowed in preelaborated units + + -- Non-static constants in preelaborated units give warnings not errors + + -- The warning about component size being ignored is suppressed + + -- The warning about size clauses being ignored is suppressed + + -- Initializing limited types gives a warning rather than an error + + -- Copying of limited objects is allowed + + -- Returning objects of limited types is allowed + + -- Non-static call in preelaborated unit give a warning, not an error + + -- Warnings on possible elaboration errors are suppressed + + -- Warnings about packing being ignored are suppressed + + -- Warnings in internal units are not suppressed (they normally are) + + -- The only special comment sequence allowed is --! + -------------------------- -- Private Declarations -- -------------------------- @@ -2107,6 +2184,7 @@ private Check_Float_Overflow : Boolean; Check_Policy_List : Node_Id; Default_Pool : Node_Id; + Default_SSO : Character; Dynamic_Elaboration_Checks : Boolean; Exception_Locations_Suppressed : Boolean; Extensions_Allowed : Boolean; @@ -2119,9 +2197,9 @@ private Optimize_Alignment_Local : Boolean; Persistent_BSS_Mode : Boolean; Polling_Required : Boolean; - Short_Descriptors : Boolean; SPARK_Mode : SPARK_Mode_Type; SPARK_Mode_Pragma : Node_Id; + Uneval_Old : Character; Use_VADS_Size : Boolean; Warnings_As_Errors_Count : Natural; end record; @@ -2142,4 +2220,7 @@ private -- Indicates which version of gcc is in use (3 = 3.x, 4 = 4.x). Note that -- gcc 2.8.1 (which used to be a value of 2) is no longer supported. + ------------------------- + -- Effect of GNAT_Mode -- + ------------------------- end Opt; diff --git a/main/gcc/ada/osint-b.adb b/main/gcc/ada/osint-b.adb index 39b7a99be84..554d804af96 100644 --- a/main/gcc/ada/osint-b.adb +++ b/main/gcc/ada/osint-b.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 @@ with Opt; use Opt; with Output; use Output; -with Targparm; use Targparm; package body Osint.B is @@ -75,9 +74,8 @@ package body Osint.B is Findex2 : Natural; Flength : Natural; - Bind_File_Prefix_Len : Natural := 2; - -- Length of binder file prefix (normally set to 2 for b~, but gets - -- reset to 3 for VMS for b__). + Bind_File_Prefix_Len : constant Natural := 2; + -- Length of binder file prefix (2 for b~) begin if Output_File_Name /= "" then @@ -120,10 +118,6 @@ package body Osint.B is if Maximum_File_Name_Length > 0 then - if OpenVMS_On_Target and then Typ /= 'c' then - Bind_File_Prefix_Len := 3; - end if; - -- Make room for the extra two characters in "b?" while Int (Flength) > @@ -139,31 +133,15 @@ package body Osint.B is File_Name (Findex1 .. Findex2 - 1); Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.'; - -- C bind file, name is b_xxx.c - - if Typ = 'c' then - Name_Buffer (2) := '_'; - Name_Buffer (Flength + 4) := 'c'; - Name_Buffer (Flength + 5) := ASCII.NUL; - Name_Len := Flength + 4; - -- Ada bind file, name is b~xxx.adb or b~xxx.ads - -- (with __ instead of ~ in VMS) - - else - if OpenVMS_On_Target then - Name_Buffer (2) := '_'; - Name_Buffer (3) := '_'; - else - Name_Buffer (2) := '~'; - end if; - Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a'; - Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd'; - Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ; - Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL; - Name_Len := Flength + Bind_File_Prefix_Len + 4; - end if; + Name_Buffer (2) := '~'; + + Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a'; + Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd'; + Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ; + Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL; + Name_Len := Flength + Bind_File_Prefix_Len + 4; end if; Bfile := Name_Find; diff --git a/main/gcc/ada/osint-b.ads b/main/gcc/ada/osint-b.ads index d24ec91ee21..a7f50252f50 100644 --- a/main/gcc/ada/osint-b.ads +++ b/main/gcc/ada/osint-b.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,17 +44,15 @@ package Osint.B is -- Binder Output -- ------------------- - -- These routines are used by the binder to generate the C or Ada source - -- files containing the binder output. The format of these files is - -- described in package Bindgen. + -- These routines are used by the binder to generate the Ada source files + -- containing the binder output. The format of these files is described in + -- package Bindgen. procedure Create_Binder_Output (Output_File_Name : String; Typ : Character; Bfile : out Name_Id); -- Creates the binder output file. Typ is one of - -- - -- 'c' create output file for case of generating C -- 'b' create body file for case of generating Ada -- 's' create spec file for case of generating Ada -- diff --git a/main/gcc/ada/osint-c.adb b/main/gcc/ada/osint-c.adb index 72395f84c6b..f955c2f34d3 100644 --- a/main/gcc/ada/osint-c.adb +++ b/main/gcc/ada/osint-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 +23,8 @@ -- -- ------------------------------------------------------------------------------ -with Hostparm; -with Opt; use Opt; -with Tree_IO; use Tree_IO; +with Opt; use Opt; +with Tree_IO; use Tree_IO; package body Osint.C is @@ -127,12 +126,7 @@ package body Osint.C is begin Get_Name_String (Src); - if Hostparm.OpenVMS then - Name_Buffer (Name_Len + 1) := '_'; - else - Name_Buffer (Name_Len + 1) := '.'; - end if; - + Name_Buffer (Name_Len + 1) := '.'; Name_Len := Name_Len + 1; Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix; Name_Len := Name_Len + Suffix'Length; @@ -197,14 +191,22 @@ package body Osint.C is procedure Create_Output_Library_Info is Dummy : Boolean; - pragma Unreferenced (Dummy); - begin Set_Library_Info_Name; Delete_File (Name_Buffer (1 .. Name_Len), Dummy); Create_File_And_Check (Output_FD, Text); end Create_Output_Library_Info; + ------------------------------ + -- Open_Output_Library_Info -- + ------------------------------ + + procedure Open_Output_Library_Info is + begin + Set_Library_Info_Name; + Open_File_To_Append_And_Check (Output_FD, Text); + end Open_Output_Library_Info; + ------------------------- -- Create_Repinfo_File -- ------------------------- diff --git a/main/gcc/ada/osint-c.ads b/main/gcc/ada/osint-c.ads index 2faef5ed787..0d6646ed3fa 100644 --- a/main/gcc/ada/osint-c.ads +++ b/main/gcc/ada/osint-c.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -127,6 +127,12 @@ package Osint.C is -- is currently being compiled (i.e. the file which was most recently -- returned by Next_Main_Source). + procedure Open_Output_Library_Info; + -- Opens the output library information file for the source file which + -- is currently being compiled (i.e. the file which was most recently + -- returned by Next_Main_Source) for appending. This is used to append + -- the globals computed in flow analysis in gnatprove mode. + procedure Write_Library_Info (Info : String); -- Writes the contents of the referenced string to the library information -- file for the main source file currently being compiled (i.e. the file diff --git a/main/gcc/ada/osint.adb b/main/gcc/ada/osint.adb index 0c15982597d..9ba18083fea 100644 --- a/main/gcc/ada/osint.adb +++ b/main/gcc/ada/osint.adb @@ -39,6 +39,7 @@ with Unchecked_Conversion; pragma Warnings (Off); -- This package is used also by gnatcoll with System.Case_Util; use System.Case_Util; +with System.CRTL; pragma Warnings (On); with GNAT.HTable; @@ -118,10 +119,11 @@ package body Osint is -- failure procedure Find_File - (N : File_Name_Type; - T : File_Type; - Found : out File_Name_Type; - Attr : access File_Attributes); + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : access File_Attributes; + Full_Name : Boolean := False); -- A version of Find_File that also returns a cache of the file attributes -- for later reuse @@ -364,8 +366,9 @@ package body Osint is S := new String (1 .. Len); - -- Read the file. Note that the loop is not necessary since the - -- whole file is read at once except on VMS. + -- Read the file. Note that the loop is probably not necessary any + -- more since the whole file is read in at once on all targets. But + -- it is harmless and might be needed in future. Curr := 1; Actual_Len := Len; @@ -472,31 +475,21 @@ package body Osint is Get_Dirs_From_File (Additional_Source_Dir => False); end if; - -- On VMS, don't expand the logical name (e.g. environment variable), - -- just put it into Unix (e.g. canonical) format. System services - -- will handle the expansion as part of the file processing. + -- Put path name in canonical form for Additional_Source_Dir in False .. True loop if Additional_Source_Dir then Search_Path := Getenv (Ada_Include_Path); if Search_Path'Length > 0 then - if Hostparm.OpenVMS then - Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:"); - else - Search_Path := To_Canonical_Path_Spec (Search_Path.all); - end if; + Search_Path := To_Canonical_Path_Spec (Search_Path.all); end if; else Search_Path := Getenv (Ada_Objects_Path); if Search_Path'Length > 0 then - if Hostparm.OpenVMS then - Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:"); - else - Search_Path := To_Canonical_Path_Spec (Search_Path.all); - end if; + Search_Path := To_Canonical_Path_Spec (Search_Path.all); end if; end if; @@ -511,9 +504,7 @@ package body Osint is -- For the compiler, if --RTS= was specified, add the runtime -- directories. - if RTS_Src_Path_Name /= null - and then RTS_Lib_Path_Name /= null - then + if RTS_Src_Path_Name /= null and then RTS_Lib_Path_Name /= null then Add_Search_Dirs (RTS_Src_Path_Name, Include); Add_Search_Dirs (RTS_Lib_Path_Name, Objects); @@ -732,6 +723,23 @@ package body Osint is end if; end Create_File_And_Check; + ----------------------------------- + -- Open_File_To_Append_And_Check -- + ----------------------------------- + + procedure Open_File_To_Append_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode) + is + begin + Output_File_Name := Name_Enter; + Fdesc := Open_Append (Name_Buffer'Address, Fmode); + + if Fdesc = Invalid_FD then + Fail ("Cannot create: " & Name_Buffer (1 .. Name_Len)); + end if; + end Open_File_To_Append_And_Check; + ------------------------ -- Current_File_Index -- ------------------------ @@ -852,13 +860,12 @@ package body Osint is Buffer : String := Name_Buffer (1 .. Name_Len); begin - -- Get the file name in canonical case to accept as is names - -- ending with ".EXE" on VMS and Windows. + -- Get the file name in canonical case to accept as is. Names + -- end with ".EXE" on Windows. Canonical_Case_File_Name (Buffer); - -- If Executable does not end with the executable suffix, add - -- it. + -- If Executable doesn't end with the executable suffix, add it if Buffer'Length <= Exec_Suffix'Length or else @@ -1076,10 +1083,15 @@ package body Osint is function Internal (F : Integer; N : C_File_Name; - A : System.Address) return Long_Integer; + A : System.Address) return CRTL.int64; pragma Import (C, Internal, "__gnat_file_length_attr"); + begin - return Internal (-1, Name, Attr.all'Address); + -- The conversion from int64 to Long_Integer is ok here as this + -- routine is only to be used by the compiler and we do not expect + -- a unit to be larger than a 32bit integer. + + return Long_Integer (Internal (-1, Name, Attr.all'Address)); end File_Length; --------------------- @@ -1142,13 +1154,14 @@ package body Osint is --------------- function Find_File - (N : File_Name_Type; - T : File_Type) return File_Name_Type + (N : File_Name_Type; + T : File_Type; + Full_Name : Boolean := False) return File_Name_Type is Attr : aliased File_Attributes; Found : File_Name_Type; begin - Find_File (N, T, Found, Attr'Access); + Find_File (N, T, Found, Attr'Access, Full_Name); return Found; end Find_File; @@ -1157,10 +1170,12 @@ package body Osint is --------------- procedure Find_File - (N : File_Name_Type; - T : File_Type; - Found : out File_Name_Type; - Attr : access File_Attributes) is + (N : File_Name_Type; + T : File_Type; + Found : out File_Name_Type; + Attr : access File_Attributes; + Full_Name : Boolean := False) + is begin Get_Name_String (N); @@ -1177,15 +1192,24 @@ package body Osint is if T = Config or else (Debug_Generated_Code - and then Name_Len > 3 - and then - (Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg" - or else - (Hostparm.OpenVMS and then - Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg"))) + and then Name_Len > 3 + and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg") then Found := N; Attr.all := Unknown_Attributes; + + if T = Config and then Full_Name then + declare + Full_Path : constant String := + Normalize_Pathname (Get_Name_String (N)); + Full_Size : constant Natural := Full_Path'Length; + begin + Name_Buffer (1 .. Full_Size) := Full_Path; + Name_Len := Full_Size; + Found := Name_Find; + end; + end if; + return; -- If we are trying to find the current main file just look in the @@ -1286,21 +1310,6 @@ package body Osint is -- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the -- POSIX command "basename argv[0]" - -- Strip off any versioning information such as found on VMS. - -- This would take the form of TOOL.exe followed by a ";" or "." - -- and a sequence of one or more numbers. - - if Command_Name (Cindex2) in '0' .. '9' then - for J in reverse Cindex1 .. Cindex2 loop - if Command_Name (J) = '.' or else Command_Name (J) = ';' then - Cindex2 := J - 1; - exit; - end if; - - exit when Command_Name (J) not in '0' .. '9'; - end loop; - end if; - -- Strip off any executable extension (usually nothing or .exe) -- but formally reported by autoconf in the variable EXEEXT @@ -1696,15 +1705,9 @@ package body Osint is function Is_Directory_Separator (C : Character) return Boolean is begin -- In addition to the default directory_separator allow the '/' to - -- act as separator since this is allowed in MS-DOS, Windows 95/NT, - -- and OS2 ports. On VMS, the situation is more complicated because - -- there are two characters to check for. - - return - C = Directory_Separator - or else C = '/' - or else (Hostparm.OpenVMS - and then (C = ']' or else C = ':')); + -- act as separator since this is allowed in MS-DOS and Windows. + + return C = Directory_Separator or else C = '/'; end Is_Directory_Separator; ------------------------- @@ -2196,11 +2199,7 @@ package body Osint is function Prep_Suffix return String is begin - if Hostparm.OpenVMS then - return "_prep"; - else - return ".prep"; - end if; + return ".prep"; end Prep_Suffix; ------------------ @@ -2338,8 +2337,9 @@ package body Osint is S := new String (1 .. Len + 1); S (Len + 1) := Path_Separator; - -- Read the file. Note that the loop is not necessary since the - -- whole file is read at once except on VMS. + -- Read the file. Note that the loop is probably not necessary since the + -- whole file is read at once but the loop is harmless and that way we + -- are sure to accomodate systems where this is not the case. Curr := 1; Actual_Len := Len; @@ -2559,9 +2559,9 @@ package body Osint is Text := new Text_Buffer (Lo .. Hi); - -- Some systems (e.g. VMS) have file types that require one - -- read per line, so read until we get the Len bytes or until - -- there are no more characters. + -- Some systems have file types that require one read per line, + -- so read until we get the Len bytes or until there are no more + -- characters. Hi := Lo; loop @@ -2608,7 +2608,7 @@ package body Osint is -- For the call to Close begin - Current_Full_Source_Name := Find_File (N, T); + Current_Full_Source_Name := Find_File (N, T, Full_Name => True); Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name); if Current_Full_Source_Name = No_File then @@ -2692,9 +2692,9 @@ package body Osint is begin -- Allocate source buffer, allowing extra character at end for EOF - -- Some systems (e.g. VMS) have file types that require one read per - -- line, so read until we get the Len bytes or until there are no - -- more characters. + -- Some systems have file types that require one read per line, + -- so read until we get the Len bytes or until there are no more + -- characters. Hi := Lo; loop @@ -2800,15 +2800,6 @@ package body Osint is Library (3 .. 2 + Name'Length) := Name; Library (3 + Name'Length) := '-'; Library (4 + Name'Length .. Library'Last) := Library_Version; - - if OpenVMS_On_Target then - for K in Library'First + 2 .. Library'Last loop - if Library (K) = '.' or else Library (K) = '-' then - Library (K) := '_'; - end if; - end loop; - end if; - return Library; end Shared_Lib; diff --git a/main/gcc/ada/osint.ads b/main/gcc/ada/osint.ads index e1c04c18467..eb569c01e1f 100644 --- a/main/gcc/ada/osint.ads +++ b/main/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 +43,9 @@ pragma Elaborate_All (System.OS_Lib); package Osint is - Multi_Unit_Index_Character : Character := '~'; + Multi_Unit_Index_Character : constant Character := '~'; -- The character before the index of the unit in a multi-unit source in ALI - -- and object file names. Changed to '$' on VMS. + -- and object file names. Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; @@ -63,8 +63,9 @@ package Osint is type File_Type is (Source, Library, Config, Definition, Preprocessing_Data); function Find_File - (N : File_Name_Type; - T : File_Type) return File_Name_Type; + (N : File_Name_Type; + T : File_Type; + Full_Name : Boolean := False) return File_Name_Type; -- Finds a source, library or config file depending on the value of T -- following the directory search order rules unless N is the name of the -- file just read with Next_Main_File and already contains directory @@ -76,6 +77,10 @@ package Osint is -- set and the file name ends in ".dg", in which case we look for the -- generated file only in the current directory, since that is where it is -- always built. + -- + -- In the case of configuration files, full path names are needed for some + -- ASIS queries. The flag Full_Name indicates that the name of the file + -- should be normalized to include a full path. function Get_File_Names_Case_Sensitive return Int; pragma Import (C, Get_File_Names_Case_Sensitive, @@ -201,33 +206,27 @@ package Osint is function To_Canonical_File_List (Wildcard_Host_File : String; Only_Dirs : Boolean) return String_Access_List_Access; - -- Expand a wildcard host syntax file or directory specification (e.g. on - -- a VMS host, any file or directory spec that contains: "*", or "%", or - -- "...") and return a list of valid Unix syntax file or directory specs. - -- If Only_Dirs is True, then only return directories. + -- Expand a wildcard host syntax file or directory specification and return + -- a list of valid Unix syntax file or directory specs. If Only_Dirs is + -- True, then only return directories. function To_Canonical_Dir_Spec (Host_Dir : String; Prefix_Style : Boolean) return String_Access; - -- Convert a host syntax directory specification (e.g. on a VMS host: - -- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir"). - -- If Prefix_Style then make it a valid file specification prefix. A file - -- specification prefix is a directory specification that can be appended - -- with a simple file specification to yield a valid absolute or relative - -- path to a file. On a conversion to Unix syntax this simply means the - -- spec has a trailing slash ("/"). + -- Convert a host syntax directory specification to canonical (Unix) + -- syntax. If Prefix_Style then make it a valid file specification prefix. + -- A file specification prefix is a directory specification that can be + -- appended with a simple file specification to yield a valid absolute + -- or relative path to a file. On a conversion to Unix syntax this simply + -- means the spec has a trailing slash ("/"). function To_Canonical_File_Spec (Host_File : String) return String_Access; - -- Convert a host syntax file specification (e.g. on a VMS host: - -- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g. - -- "/sys$device/dir/file.ext.69"). + -- Convert a host syntax file specification to canonical (Unix) syntax function To_Canonical_Path_Spec (Host_Path : String) return String_Access; - -- Convert a host syntax Path specification (e.g. on a VMS host: - -- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g. - -- "/sys$device/foo:disk$user/foo"). + -- Convert a host syntax Path specification to canonical (Unix) syntax function To_Host_Dir_Spec (Canonical_Dir : String; @@ -254,7 +253,7 @@ package Osint is -- Returns the runtime shared library in the form -l- where -- version is the GNAT runtime library option for the platform. For example -- this routine called with Name set to "gnat" will return "-lgnat-5.02" - -- on UNIX and Windows and -lgnat_5_02 on VMS. + -- on UNIX and Windows. --------------------- -- File attributes -- @@ -731,6 +730,15 @@ private -- parameter is set to either Text or Binary (for details see description -- of System.OS_Lib.Create_File). + procedure Open_File_To_Append_And_Check + (Fdesc : out File_Descriptor; + Fmode : Mode); + -- Opens the file whose name (NUL terminated) is in Name_Buffer (with the + -- length in Name_Len), and place the resulting descriptor in Fdesc. Issue + -- message and exit with fatal error if file cannot be opened. The Fmode + -- parameter is set to either Text or Binary (for details see description + -- of System.OS_Lib.Open_Append). + type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified); -- Program currently running procedure Set_Program (P : Program_Type); diff --git a/main/gcc/ada/output.ads b/main/gcc/ada/output.ads index e4137c2add6..71b25ad4302 100644 --- a/main/gcc/ada/output.ads +++ b/main/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -209,11 +209,8 @@ private Buffer : String (1 .. Buffer_Max + 1) := (others => '*'); for Buffer'Alignment use 4; - -- Buffer used to build output line. We do line buffering because it - -- is needed for the support of the debug-generated-code option (-gnatD). - -- Historically it was first added because on VMS, line buffering is - -- needed with certain file formats. So in any case line buffering must - -- be retained for this purpose, even if other reasons disappear. Note + -- Buffer used to build output line. We do line buffering because it is + -- needed for the support of the debug-generated-code option (-gnatD). Note -- any attempt to write more output to a line than can fit in the buffer -- will be silently ignored. The alignment clause improves the efficiency -- of the save/restore procedures. diff --git a/main/gcc/ada/par-ch12.adb b/main/gcc/ada/par-ch12.adb index 839697c7663..39169e1fc80 100644 --- a/main/gcc/ada/par-ch12.adb +++ b/main/gcc/ada/par-ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -168,6 +168,7 @@ package body Ch12 is if Token = Tok_Use then Append (P_Use_Clause, Decls); + else -- Parse a generic parameter declaration diff --git a/main/gcc/ada/par-ch13.adb b/main/gcc/ada/par-ch13.adb index 387c83ef839..2265bbf796d 100644 --- a/main/gcc/ada/par-ch13.adb +++ b/main/gcc/ada/par-ch13.adb @@ -154,6 +154,9 @@ package body Ch13 is Aspects : List_Id; OK : Boolean; + Opt : Boolean; + -- True if current aspect takes an optional argument + begin Aspects := Empty_List; @@ -170,6 +173,8 @@ package body Ch13 is Scan; -- past WITH Aspects := Empty_List; + -- Loop to scan aspects + loop OK := True; @@ -195,7 +200,7 @@ package body Ch13 is -- The aspect mark is not recognized if A_Id = No_Aspect then - Error_Msg_SC ("aspect identifier expected"); + Error_Msg_N ("& is not a valid aspect identifier", Token_Node); OK := False; -- Check bad spelling @@ -203,8 +208,8 @@ package body Ch13 is for J in Aspect_Id_Exclude_No_Aspect loop if Is_Bad_Spelling_Of (Token_Name, Aspect_Names (J)) then Error_Msg_Name_1 := Aspect_Names (J); - Error_Msg_SC -- CODEFIX - ("\possible misspelling of%"); + Error_Msg_N -- CODEFIX + ("\possible misspelling of%", Token_Node); exit; end if; end loop; @@ -223,9 +228,13 @@ package body Ch13 is Scan; -- past arrow Set_Expression (Aspect, P_Expression); - -- The aspect may behave as a boolean aspect + -- If we have a correct terminator (comma or semicolon, or a + -- reasonable likely missing comma), then just proceed. - elsif Token = Tok_Comma then + elsif Token = Tok_Comma or else + Token = Tok_Semicolon or else + Token = Tok_Identifier + then null; -- Otherwise the aspect contains a junk definition @@ -242,6 +251,9 @@ package body Ch13 is else Scan; -- past identifier + Opt := Aspect_Argument (A_Id) = Optional_Expression + or else + Aspect_Argument (A_Id) = Optional_Name; -- Check for 'Class present @@ -279,23 +291,21 @@ package body Ch13 is -- definitions are not considered. if Token = Tok_Comma or else Token = Tok_Semicolon then - if Aspect_Argument (A_Id) /= Optional_Expression - and then Aspect_Argument (A_Id) /= Optional_Name - then + if not Opt then Error_Msg_Node_1 := Identifier (Aspect); Error_Msg_AP ("aspect& requires an aspect definition"); OK := False; end if; - -- Check for a missing arrow when the aspect has a definition + -- Here we do not have a comma or a semicolon, we are done if we + -- do not have an arrow and the aspect does not need an argument - elsif not Semicolon and then Token /= Tok_Arrow then - if Aspect_Argument (A_Id) /= Optional_Expression - and then Aspect_Argument (A_Id) /= Optional_Name - then - T_Arrow; - Resync_To_Semicolon; - end if; + elsif Opt and then Token /= Tok_Arrow then + null; + + -- Here we have either an arrow, or an aspect that definitely + -- needs an aspect definition, and we will look for one even if + -- no arrow is preseant. -- Otherwise we have an aspect definition @@ -445,6 +455,12 @@ package body Ch13 is end if; end if; + -- Note if inside Depends aspect + + if A_Id = Aspect_Depends then + Inside_Depends := True; + end if; + -- Parse the aspect definition depening on the expected -- argument kind. @@ -460,6 +476,10 @@ package body Ch13 is Aspect_Argument (A_Id) = Optional_Expression); Set_Expression (Aspect, P_Expression); end if; + + -- Unconditionally reset flag for Inside_Depends + + Inside_Depends := False; end if; -- Add the aspect to the resulting list only when it was properly @@ -468,89 +488,92 @@ package body Ch13 is if OK then Append (Aspect, Aspects); end if; + end if; - -- The aspect specification list contains more than one aspect + -- Merge here after good or bad aspect (we should be at a comma + -- or a semicolon, but there might be other possible errors). - if Token = Tok_Comma then - Scan; -- past comma - goto Continue; + -- The aspect specification list contains more than one aspect - -- Check for a missing comma between two aspects. Emit an error - -- and proceed to the next aspect. + if Token = Tok_Comma then + Scan; -- past comma + goto Continue; - elsif Token = Tok_Identifier - and then Get_Aspect_Id (Token_Name) /= No_Aspect - then - declare - Scan_State : Saved_Scan_State; + -- Check for a missing comma between two aspects. Emit an error + -- and proceed to the next aspect. - begin - Save_Scan_State (Scan_State); - Scan; -- past identifier + elsif Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + declare + Scan_State : Saved_Scan_State; - -- Attempt to detect ' or => following a potential aspect - -- mark. + begin + Save_Scan_State (Scan_State); + Scan; -- past identifier - if Token = Tok_Apostrophe or else Token = Tok_Arrow then - Restore_Scan_State (Scan_State); - Error_Msg_AP -- CODEFIX - ("|missing "","""); - goto Continue; + -- Attempt to detect ' or => following a potential aspect + -- mark. - -- The construct following the current aspect is not an - -- aspect. + if Token = Tok_Apostrophe or else Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_AP -- CODEFIX + ("|missing "","""); + goto Continue; - else - Restore_Scan_State (Scan_State); - end if; - end; + -- The construct following the current aspect is not an + -- aspect. - -- Check for a mistyped semicolon in place of a comma between two - -- aspects. Emit an error and proceed to the next aspect. + else + Restore_Scan_State (Scan_State); + end if; + end; - elsif Token = Tok_Semicolon then - declare - Scan_State : Saved_Scan_State; + -- Check for a mistyped semicolon in place of a comma between two + -- aspects. Emit an error and proceed to the next aspect. - begin - Save_Scan_State (Scan_State); - Scan; -- past semicolon + elsif Token = Tok_Semicolon then + declare + Scan_State : Saved_Scan_State; - if Token = Tok_Identifier - and then Get_Aspect_Id (Token_Name) /= No_Aspect - then - Scan; -- past identifier + begin + Save_Scan_State (Scan_State); + Scan; -- past semicolon + + if Token = Tok_Identifier + and then Get_Aspect_Id (Token_Name) /= No_Aspect + then + Scan; -- past identifier - -- Attempt to detect ' or => following a potential aspect - -- mark. + -- Attempt to detect ' or => following a potential aspect + -- mark. - if Token = Tok_Apostrophe or else Token = Tok_Arrow then - Restore_Scan_State (Scan_State); - Error_Msg_SC -- CODEFIX - ("|"";"" should be "","""); - Scan; -- past semicolon - goto Continue; - end if; + if Token = Tok_Apostrophe or else Token = Tok_Arrow then + Restore_Scan_State (Scan_State); + Error_Msg_SC -- CODEFIX + ("|"";"" should be "","""); + Scan; -- past semicolon + goto Continue; end if; + end if; - -- The construct following the current aspect is not an - -- aspect. + -- The construct following the current aspect is not an + -- aspect. - Restore_Scan_State (Scan_State); - end; - end if; + Restore_Scan_State (Scan_State); + end; + end if; - -- Must be terminator character + -- Must be terminator character - if Semicolon then - T_Semicolon; - end if; + if Semicolon then + T_Semicolon; + end if; - exit; + exit; - <> - null; - end if; + <> + null; end loop; return Aspects; diff --git a/main/gcc/ada/par-ch2.adb b/main/gcc/ada/par-ch2.adb index 2218dacb17e..99d1f2de8c7 100644 --- a/main/gcc/ada/par-ch2.adb +++ b/main/gcc/ada/par-ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -298,13 +298,19 @@ package body Ch2 is Import_Check_Required := False; end if; + -- Set global to indicate if we are within a Depends pragma + + if Chars (Ident_Node) = Name_Depends then + Inside_Depends := True; + end if; + -- Scan arguments. We assume that arguments are present if there is -- a left paren, or if a semicolon is missing and there is another -- token on the same line as the pragma name. if Token = Tok_Left_Paren or else (Token /= Tok_Semicolon - and then not Token_Is_At_Start_Of_Line) + and then not Token_Is_At_Start_Of_Line) then Set_Pragma_Argument_Associations (Prag_Node, New_List); T_Left_Paren; @@ -349,6 +355,11 @@ package body Ch2 is Semicolon_Loc := Token_Ptr; + -- Cancel indication of being within Depends pragm. Can be done + -- unconditionally, since quicker than doing a test. + + Inside_Depends := False; + -- Now we have two tasks left, we need to scan out the semicolon -- following the pragma, and we have to call Par.Prag to process -- the pragma. Normally we do them in this order, however, there diff --git a/main/gcc/ada/par-ch3.adb b/main/gcc/ada/par-ch3.adb index e9524fa4de7..7e4dc8f2623 100644 --- a/main/gcc/ada/par-ch3.adb +++ b/main/gcc/ada/par-ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -652,6 +652,10 @@ package body Ch3 is Typedef_Node := P_Record_Definition; Set_Limited_Present (Typedef_Node, True); + End_Labl := Make_Identifier (Token_Ptr, Chars (Ident_Node)); + Set_Comes_From_Source (End_Labl, False); + + Set_End_Label (Typedef_Node, End_Labl); -- Ada 2005 (AI-251): LIMITED INTERFACE @@ -1217,19 +1221,13 @@ package body Ch3 is function P_Constraint_Opt return Node_Id is begin - if Token = Tok_Range - or else Bad_Spelling_Of (Tok_Range) - then + if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then return P_Range_Constraint; - elsif Token = Tok_Digits - or else Bad_Spelling_Of (Tok_Digits) - then + elsif Token = Tok_Digits or else Bad_Spelling_Of (Tok_Digits) then return P_Digits_Constraint; - elsif Token = Tok_Delta - or else Bad_Spelling_Of (Tok_Delta) - then + elsif Token = Tok_Delta or else Bad_Spelling_Of (Tok_Delta) then return P_Delta_Constraint; elsif Token = Tok_Left_Paren then @@ -1239,6 +1237,31 @@ package body Ch3 is Ignore (Tok_In); return P_Constraint_Opt; + -- One more possibility is e.g. 1 .. 10 (i.e. missing RANGE keyword) + + elsif Token = Tok_Identifier or else + Token = Tok_Integer_Literal or else + Token = Tok_Real_Literal + then + declare + Scan_State : Saved_Scan_State; + + begin + Save_Scan_State (Scan_State); -- at identifier or literal + Scan; -- past identifier or literal + + if Token = Tok_Dot_Dot then + Restore_Scan_State (Scan_State); + Error_Msg_BC ("missing RANGE keyword"); + return P_Range_Constraint; + else + Restore_Scan_State (Scan_State); + return Empty; + end if; + end; + + -- Nothing worked, no constraint there + else return Empty; end if; @@ -2033,7 +2056,9 @@ package body Ch3 is -- RANGE_CONSTRAINT ::= range RANGE - -- The caller has checked that the initial token is RANGE + -- The caller has checked that the initial token is RANGE or some + -- misspelling of it, or it may be absent completely (and a message + -- has already been issued). -- Error recovery: cannot raise Error_Resync @@ -2042,7 +2067,13 @@ package body Ch3 is begin Range_Node := New_Node (N_Range_Constraint, Token_Ptr); - Scan; -- past RANGE + + -- Skip range keyword if present + + if Token = Tok_Range or else Bad_Spelling_Of (Tok_Range) then + Scan; -- past RANGE + end if; + Set_Range_Expression (Range_Node, P_Range); return Range_Node; end P_Range_Constraint; @@ -3903,6 +3934,7 @@ package body Ch3 is Access_Loc : constant Source_Ptr := Token_Ptr; Prot_Flag : Boolean; Not_Null_Present : Boolean := False; + Not_Null_Subtype : Boolean := False; Type_Def_Node : Node_Id; Result_Not_Null : Boolean; Result_Node : Node_Id; @@ -3937,8 +3969,18 @@ package body Ch3 is begin if not Header_Already_Parsed then - Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) + + -- NOT NULL ACCESS .. is a common form of access definition. + -- ACCESS NOT NULL .. is certainly rare, but syntactically legal. + -- NOT NULL ACCESS NOT NULL .. is rarer yet, and also legal. + -- The last two cases are only meaningful if the following subtype + -- indication denotes an access type (semantic check). The flag + -- Not_Null_Subtype indicates that this second null exclusion is + -- present in the access type definition. + + Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) Scan; -- past ACCESS + Not_Null_Subtype := P_Null_Exclusion; -- Might also appear end if; if Token_Name = Name_Protected then @@ -4013,6 +4055,7 @@ package body Ch3 is Type_Def_Node := New_Node (N_Access_To_Object_Definition, Access_Loc); Set_Null_Exclusion_Present (Type_Def_Node, Not_Null_Present); + Set_Null_Excluding_Subtype (Type_Def_Node, Not_Null_Subtype); if Token = Tok_All or else Token = Tok_Constant then if Ada_Version = Ada_83 then diff --git a/main/gcc/ada/par-ch4.adb b/main/gcc/ada/par-ch4.adb index 105732a14eb..8f6da4eb4c3 100644 --- a/main/gcc/ada/par-ch4.adb +++ b/main/gcc/ada/par-ch4.adb @@ -42,6 +42,7 @@ package body Ch4 is Attribute_Img => True, Attribute_Loop_Entry => True, Attribute_Old => True, + Attribute_Result => True, Attribute_Stub_Type => True, Attribute_Version => True, Attribute_Type_Key => True, @@ -2105,7 +2106,7 @@ package body Ch4 is Node1 := New_Op_Node (P_Unary_Adding_Operator, Tokptr); if Style_Check then - Style.Check_Unary_Plus_Or_Minus; + Style.Check_Unary_Plus_Or_Minus (Inside_Depends); end if; Scan; -- past operator diff --git a/main/gcc/ada/par-ch5.adb b/main/gcc/ada/par-ch5.adb index 1d5504df922..7b1bc44f39d 100644 --- a/main/gcc/ada/par-ch5.adb +++ b/main/gcc/ada/par-ch5.adb @@ -699,6 +699,11 @@ package body Ch5 is else TF_Semicolon; + + -- Normal processing as though semicolon were present + + Change_Name_To_Procedure_Call_Statement (Name_Node); + Append_To (Statement_List, Name_Node); Statement_Required := False; end if; diff --git a/main/gcc/ada/par-prag.adb b/main/gcc/ada/par-prag.adb index a7509af8c20..b440122dc62 100644 --- a/main/gcc/ada/par-prag.adb +++ b/main/gcc/ada/par-prag.adb @@ -1151,7 +1151,6 @@ begin Pragma_Assertion_Policy | Pragma_Assume | Pragma_Assume_No_Invalid_Values | - Pragma_AST_Entry | Pragma_All_Calls_Remote | Pragma_Allow_Integer_Address | Pragma_Annotate | @@ -1187,6 +1186,7 @@ begin 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 | @@ -1201,7 +1201,6 @@ begin Pragma_Elaboration_Checks | Pragma_Enable_Atomic_Synchronization | Pragma_Export | - Pragma_Export_Exception | Pragma_Export_Function | Pragma_Export_Object | Pragma_Export_Procedure | @@ -1213,14 +1212,12 @@ begin Pragma_Favor_Top_Level | Pragma_Fast_Math | Pragma_Finalize_Storage_Only | - Pragma_Float_Representation | Pragma_Global | Pragma_Ident | Pragma_Implementation_Defined | Pragma_Implemented | Pragma_Implicit_Packing | Pragma_Import | - Pragma_Import_Exception | Pragma_Import_Function | Pragma_Import_Object | Pragma_Import_Procedure | @@ -1252,7 +1249,6 @@ begin Pragma_Linker_Section | Pragma_Lock_Free | Pragma_Locking_Policy | - Pragma_Long_Float | Pragma_Loop_Invariant | Pragma_Loop_Optimize | Pragma_Loop_Variant | @@ -1261,6 +1257,7 @@ begin Pragma_Main_Storage | Pragma_Memory_Size | Pragma_No_Body | + Pragma_No_Elaboration_Code_All | Pragma_No_Inline | Pragma_No_Return | Pragma_No_Run_Time | @@ -1337,6 +1334,7 @@ begin Pragma_Type_Invariant | Pragma_Type_Invariant_Class | Pragma_Unchecked_Union | + Pragma_Unevaluated_Use_Of_Old | Pragma_Unimplemented_Unit | Pragma_Universal_Aliasing | Pragma_Universal_Data | diff --git a/main/gcc/ada/par.adb b/main/gcc/ada/par.adb index 88720dbc8d6..53b19f53fce 100644 --- a/main/gcc/ada/par.adb +++ b/main/gcc/ada/par.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -947,12 +947,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- for aspects so it does not matter whether the aspect specifications -- are terminated by semicolon or some other character. - function Get_Aspect_Specifications - (Semicolon : Boolean := True) return List_Id; - -- Parse a list of aspects but do not attach them to a declaration node. - -- Subsidiary to the following procedure. Used when parsing a subprogram - -- specification that may be a declaration or a body. - procedure P_Aspect_Specifications (Decl : Node_Id; Semicolon : Boolean := True); @@ -977,6 +971,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is -- are also ignored, but no error message is given (this is used when -- the caller has already taken care of the error message). + function Get_Aspect_Specifications + (Semicolon : Boolean := True) return List_Id; + -- Parse a list of aspects but do not attach them to a declaration node. + -- Subsidiary to P_Aspect_Specifications procedure. Used when parsing + -- a subprogram specification that may be a declaration or a body. + -- Semicolon has the same meaning as for P_Aspect_Specifications above. + function P_Code_Statement (Subtype_Mark : Node_Id) return Node_Id; -- Function to parse a code statement. The caller has scanned out -- the name to be used as the subtype mark (but has not checked that @@ -1563,9 +1564,7 @@ begin -- mode, check that language-defined units are compiled in GNAT -- mode. For this purpose we do NOT consider renamings in annex -- J as predefined. That allows users to compile their own - -- versions of these files, and in particular, in the VMS - -- implementation, the DEC versions can be substituted for the - -- standard Ada 95 versions. Another exception is System.RPC + -- versions of these files. Another exception is System.RPC -- and its children. This allows a user to supply their own -- communication layer. diff --git a/main/gcc/ada/prepcomp.adb b/main/gcc/ada/prepcomp.adb index 2cc1c5e684f..737ebf25e51 100644 --- a/main/gcc/ada/prepcomp.adb +++ b/main/gcc/ada/prepcomp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Scn; use Scn; with Sinput.L; use Sinput.L; with Stringt; use Stringt; with Table; -with Types; use Types; package body Prepcomp is @@ -137,6 +136,16 @@ package body Prepcomp is end loop; end Add_Command_Line_Symbols; + -------------------- + -- Add_Dependency -- + -------------------- + + procedure Add_Dependency (S : Source_File_Index) is + begin + Dependencies.Increment_Last; + Dependencies.Table (Dependencies.Last) := S; + end Add_Dependency; + ---------------------- -- Add_Dependencies -- ---------------------- @@ -543,9 +552,7 @@ package body Prepcomp is -- Record the dependency on the preprocessor data file - Dependencies.Increment_Last; - Dependencies.Table (Dependencies.Last) := - Source_Index_Of_Preproc_Data_File; + Add_Dependency (Source_Index_Of_Preproc_Data_File); end Parse_Preprocessing_Data_File; --------------------------- @@ -676,8 +683,7 @@ package body Prepcomp is end loop; if Add_Deffile then - Dependencies.Increment_Last; - Dependencies.Table (Dependencies.Last) := Deffile; + Add_Dependency (Deffile); end if; end; diff --git a/main/gcc/ada/prepcomp.ads b/main/gcc/ada/prepcomp.ads index 00ddf13d2d7..20a69bfbd4c 100644 --- a/main/gcc/ada/prepcomp.ads +++ b/main/gcc/ada/prepcomp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,12 +26,19 @@ -- This package stores all preprocessing data for the compiler with Namet; use Namet; +with Types; use Types; package Prepcomp is + procedure Add_Dependency (S : Source_File_Index); + -- Add a dependency on a non-source file. This is used internally for the + -- preprocessing data file and the preprocessing definition file, and also + -- externally for non-temporary configuration pragmas files. + procedure Add_Dependencies; -- Add dependencies on the preprocessing data file and the preprocessing - -- definition files, if any. + -- definition files, if any, and the non-temporary configuration pragmas + -- files, if any. procedure Check_Symbols; -- Check if there are preprocessing symbols on the command line and set diff --git a/main/gcc/ada/prj-attr-pm.adb b/main/gcc/ada/prj-attr-pm.adb index 9b75c0526e4..f9f41b16283 100644 --- a/main/gcc/ada/prj-attr-pm.adb +++ b/main/gcc/ada/prj-attr-pm.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ package body Prj.Attr.PM is Attr_Kind => Unknown, Read_Only => False, Others_Allowed => False, + Default => Empty_Value, Next => Package_Attributes.Table (To_Package.Value).First_Attribute)); diff --git a/main/gcc/ada/prj-attr.adb b/main/gcc/ada/prj-attr.adb index 04ce48a4aa8..d515c01a1b2 100644 --- a/main/gcc/ada/prj-attr.adb +++ b/main/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 @@ package body Prj.Attr is -- Data for predefined attributes and packages - -- Names are in lower case and end with '#' + -- Names are in lower case and end with '#' or 'D' -- Package names are preceded by 'P' @@ -55,11 +55,17 @@ package body Prj.Attr is -- 'c' same as 'b', with optional index -- The third optional letter is - -- 'R' to indicate that the attribute is read-only - -- 'O' to indicate that others is allowed as an index for an associative - -- array + -- 'R' the attribute is read-only + -- 'O' others is allowed as an index for an associative array - -- End is indicated by two consecutive '#' + -- If the character after the name in lower case letter is a 'D' (for + -- default), then 'D' must be followed by an enumeration value of type + -- Attribute_Default_Value, followed by a '#'. + + -- Example: + -- "SVobject_dirDdot_value#" + + -- End is indicated by two consecutive '#'. Initialization_Data : constant String := @@ -76,9 +82,9 @@ package body Prj.Attr is -- Directories - "SVobject_dir#" & - "SVexec_dir#" & - "LVsource_dirs#" & + "SVobject_dirDdot_value#" & + "SVexec_dirDobject_dir_value#" & + "LVsource_dirsDdot_value#" & "Lainherit_source_path#" & "LVexcluded_source_dirs#" & "LVignore_source_sub_dirs#" & @@ -129,7 +135,7 @@ package body Prj.Attr is "Satoolchain_description#" & "Saobject_generated#" & "Saobjects_linked#" & - "SVtarget#" & + "SVtargetDtarget_value#" & -- Configuration - Libraries @@ -416,6 +422,21 @@ package body Prj.Attr is Package_Names (Last_Package_Name) := new String'(Name); end Add_Package_Name; + -------------------------- + -- Attribute_Default_Of -- + -------------------------- + + function Attribute_Default_Of + (Attribute : Attribute_Node_Id) return Attribute_Default_Value + is + begin + if Attribute = Empty_Attribute then + return Empty_Value; + else + return Attrs.Table (Attribute.Value).Default; + end if; + end Attribute_Default_Of; + ----------------------- -- Attribute_Kind_Of -- ----------------------- @@ -482,6 +503,7 @@ package body Prj.Attr is First_Attribute : Attr_Node_Id := Attr.First_Attribute; Read_Only : Boolean; Others_Allowed : Boolean; + Default : Attribute_Default_Value; function Attribute_Location return String; -- Returns a string depending if we are in the project level attributes @@ -611,9 +633,11 @@ package body Prj.Attr is Read_Only := False; Others_Allowed := False; + Default := Empty_Value; if Initialization_Data (Start) = 'R' then Read_Only := True; + Default := Read_Only_Value; Start := Start + 1; elsif Initialization_Data (Start) = 'O' then @@ -623,12 +647,40 @@ package body Prj.Attr is Finish := Start; - while Initialization_Data (Finish) /= '#' loop + while Initialization_Data (Finish) /= '#' + and then + Initialization_Data (Finish) /= 'D' + loop Finish := Finish + 1; end loop; Attribute_Name := Name_Id_Of (Initialization_Data (Start .. Finish - 1)); + + if Initialization_Data (Finish) = 'D' then + Start := Finish + 1; + + Finish := Start; + while Initialization_Data (Finish) /= '#' loop + Finish := Finish + 1; + end loop; + + declare + Default_Name : constant String := + Initialization_Data (Start .. Finish - 1); + pragma Unsuppress (All_Checks); + begin + Default := Attribute_Default_Value'Value (Default_Name); + exception + when Constraint_Error => + Osint.Fail + ("illegal default value """ & + Default_Name & + """ for attribute " & + Get_Name_String (Attribute_Name)); + end; + end if; + Attrs.Increment_Last; if Current_Attribute = Empty_Attr then @@ -662,6 +714,7 @@ package body Prj.Attr is Attr_Kind => Attr_Kind, Read_Only => Read_Only, Others_Allowed => Others_Allowed, + Default => Default, Next => Empty_Attr); Start := Finish + 1; end if; @@ -769,8 +822,9 @@ package body Prj.Attr is In_Package : Package_Node_Id; Attr_Kind : Defined_Attribute_Kind; Var_Kind : Defined_Variable_Kind; - Index_Is_File_Name : Boolean := False; - Opt_Index : Boolean := False) + Index_Is_File_Name : Boolean := False; + Opt_Index : Boolean := False; + Default : Attribute_Default_Value := Empty_Value) is Attr_Name : Name_Id; First_Attr : Attr_Node_Id := Empty_Attr; @@ -840,6 +894,7 @@ package body Prj.Attr is Attr_Kind => Real_Attr_Kind, Read_Only => False, Others_Allowed => False, + Default => Default, Next => First_Attr); Package_Attributes.Table (In_Package.Value).First_Attribute := @@ -952,6 +1007,7 @@ package body Prj.Attr is Attr_Kind => Attr_Kind, Read_Only => False, Others_Allowed => False, + Default => Attributes (Index).Default, Next => First_Attr); First_Attr := Attrs.Last; end loop; diff --git a/main/gcc/ada/prj-attr.ads b/main/gcc/ada/prj-attr.ads index dc60cd69135..e821a8249dc 100644 --- a/main/gcc/ada/prj-attr.ads +++ b/main/gcc/ada/prj-attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -107,6 +107,10 @@ package Prj.Attr is Var_Kind : Defined_Variable_Kind; -- The attribute value kind: single or list + Default : Attribute_Default_Value := Empty_Value; + -- The value of the attribute when referenced if the attribute has not + -- yet been declared. + end record; -- Name and characteristics of an attribute in a package registered -- explicitly with Register_New_Package (see below). @@ -190,6 +194,11 @@ package Prj.Attr is -- Set the variable kind of a known attribute. Does nothing if Attribute is -- Empty_Attribute. + function Attribute_Default_Of + (Attribute : Attribute_Node_Id) return Attribute_Default_Value; + -- Returns the default of the attribute, Read_Only_Value for read only + -- attributes, Empty_Value when default not specified, or specified value. + function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean; -- Returns True if Attribute is a known attribute and may have an -- optional index. Returns False otherwise. @@ -231,13 +240,14 @@ package Prj.Attr is In_Package : Package_Node_Id; Attr_Kind : Defined_Attribute_Kind; Var_Kind : Defined_Variable_Kind; - Index_Is_File_Name : Boolean := False; - Opt_Index : Boolean := False); + Index_Is_File_Name : Boolean := False; + Opt_Index : Boolean := False; + Default : Attribute_Default_Value := Empty_Value); -- Add a new attribute to registered package In_Package. Fails if Name -- (the attribute name) is empty, if In_Package is Empty_Package or if -- the attribute name has a duplicate name. See definition of type -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind, - -- Index_Is_File_Name and Opt_Index. + -- Index_Is_File_Name, Opt_Index, and Default. function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id; -- Returns the package node id of the package with name Name. Returns @@ -320,6 +330,7 @@ private Attr_Kind : Attribute_Kind; Read_Only : Boolean; Others_Allowed : Boolean; + Default : Attribute_Default_Value; Next : Attr_Node_Id; end record; -- Data for an attribute diff --git a/main/gcc/ada/prj-conf.adb b/main/gcc/ada/prj-conf.adb index 1becd7028c3..095c2d1c020 100644 --- a/main/gcc/ada/prj-conf.adb +++ b/main/gcc/ada/prj-conf.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Hostparm; with Makeutl; use Makeutl; with MLib.Tgt; with Opt; use Opt; @@ -64,6 +63,14 @@ package body Prj.Conf is -- Stores the runtime names for the various languages. This is in general -- set from a --RTS command line option. + procedure Locate_Runtime + (Language : Name_Id; + Env : Prj.Tree.Environment); + -- If RTS_Name is a base name (a name without path separator), then + -- do nothing. Otherwise, convert it to an absolute path (possibly by + -- searching it in the project path) and call Set_Runtime_For with the + -- absolute path. Raise Invalid_Config if the path does not exist. + ----------------------- -- Local_Subprograms -- ----------------------- @@ -721,7 +728,7 @@ package body Prj.Conf is Set_Runtime_For (Name_Ada, Name_Buffer (7 .. Name_Len)); - Locate_Runtime (Name_Ada, Project_Tree, Env); + Locate_Runtime (Name_Ada, Env); end if; elsif Name_Len > 7 @@ -748,7 +755,7 @@ package body Prj.Conf is if not Runtime_Name_Set_For (Lang) then Set_Runtime_For (Lang, RTS); - Locate_Runtime (Lang, Project_Tree, Env); + Locate_Runtime (Lang, Env); end if; end; end if; @@ -1408,18 +1415,10 @@ package body Prj.Conf is <> if Automatically_Generated then - if Hostparm.OpenVMS then - -- There is no gprconfig on VMS - - Raise_Invalid_Config - ("could not locate any configuration project file"); + -- This might raise an Invalid_Config exception - else - -- This might raise an Invalid_Config exception - - Do_Autoconf; - end if; + Do_Autoconf; -- If the config file is not auto-generated, warn if there is any --RTS -- switch, but not when the config file is generated in memory. @@ -1517,9 +1516,8 @@ package body Prj.Conf is -------------------- procedure Locate_Runtime - (Language : Name_Id; - Project_Tree : Prj.Project_Tree_Ref; - Env : Prj.Tree.Environment) + (Language : Name_Id; + Env : Prj.Tree.Environment) is function Is_Base_Name (Path : String) return Boolean; -- Returns True if Path has no directory separator @@ -1555,7 +1553,7 @@ package body Prj.Conf is Find_Rts_In_Path (Env.Project_Path, RTS_Name); if Full_Path = null then - Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name); + Raise_Invalid_Config ("cannot find RTS " & RTS_Name); end if; Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all)); diff --git a/main/gcc/ada/prj-conf.ads b/main/gcc/ada/prj-conf.ads index df830ad93b6..029310f9dd1 100644 --- a/main/gcc/ada/prj-conf.ads +++ b/main/gcc/ada/prj-conf.ads @@ -216,13 +216,4 @@ package Prj.Conf is function Runtime_Name_Set_For (Language : Name_Id) return Boolean; -- Returns True only if Set_Runtime_For has been called for the Language - procedure Locate_Runtime - (Language : Name_Id; - Project_Tree : Prj.Project_Tree_Ref; - Env : Prj.Tree.Environment); - -- If RTS_Name is a base name (a name without path separator), then - -- do nothing. Otherwise, convert it to an absolute path (possibly by - -- searching it in the project path) and call Set_Runtime_For with the - -- absolute path. Fail the program if the path does not exist. - end Prj.Conf; diff --git a/main/gcc/ada/prj-dect.adb b/main/gcc/ada/prj-dect.adb index a4d07d8828b..672c45419a9 100644 --- a/main/gcc/ada/prj-dect.adb +++ b/main/gcc/ada/prj-dect.adb @@ -214,10 +214,12 @@ package body Prj.Dect is Project_Qualifier_Of (Project, In_Tree); Name : constant Name_Id := Name_Of (Current_Package, In_Tree); begin - if (Qualif = Aggregate and then Name /= Snames.Name_Builder) - or else (Qualif = Aggregate_Library - and then Name /= Snames.Name_Builder - and then Name /= Snames.Name_Install) + if Name /= Snames.Name_Ide + and then + ((Qualif = Aggregate and then Name /= Snames.Name_Builder) + or else + (Qualif = Aggregate_Library and then Name /= Snames.Name_Builder + and then Name /= Snames.Name_Install)) then Error_Msg_Name_1 := Name; Error_Msg @@ -825,11 +827,11 @@ package body Prj.Dect is if Present (Case_Variable) then String_Type := String_Type_Of (Case_Variable, In_Tree); - if No (String_Type) then + if Expression_Kind_Of (Case_Variable, In_Tree) /= Single then Error_Msg (Flags, "variable """ & Get_Name_String (Name_Of (Case_Variable, In_Tree)) & - """ is not typed", + """ is not a single string", Variable_Location); end if; end if; @@ -912,7 +914,8 @@ package body Prj.Dect is Parse_Choice_List (In_Tree => In_Tree, First_Choice => First_Choice, - Flags => Flags); + Flags => Flags, + String_Type => Present (String_Type)); Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); Expect (Tok_Arrow, "`=>`"); @@ -939,7 +942,8 @@ package body Prj.Dect is End_Case_Construction (Check_All_Labels => not When_Others and not Quiet_Output, Case_Location => Location_Of (Case_Construction, In_Tree), - Flags => Flags); + Flags => Flags, + String_Type => Present (String_Type)); Expect (Tok_End, "`END CASE`"); Remove_Next_End_Node; @@ -1558,7 +1562,6 @@ package body Prj.Dect is if Token = Tok_Right_Paren then Scan (In_Tree); end if; - end Parse_String_Type_Declaration; -------------------------------- diff --git a/main/gcc/ada/prj-env.adb b/main/gcc/ada/prj-env.adb index 0bb0eb192aa..30f2b993e03 100644 --- a/main/gcc/ada/prj-env.adb +++ b/main/gcc/ada/prj-env.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Fmap; -with Hostparm; with Makeutl; use Makeutl; with Opt; with Osint; use Osint; @@ -131,7 +130,6 @@ package body Prj.Env is In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is - pragma Unreferenced (Dummy); begin Add_To_Path (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); @@ -201,7 +199,7 @@ package body Prj.Env is In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is - pragma Unreferenced (Dummy, In_Tree); + pragma Unreferenced (In_Tree); Path : constant Path_Name_Type := Get_Object_Directory @@ -1259,7 +1257,7 @@ package body Prj.Env is Tree : Project_Tree_Ref; Dummy : in out Integer) is - pragma Unreferenced (Dummy, Tree); + pragma Unreferenced (Tree); begin -- ??? Set_Ada_Paths has a different behavior for library project @@ -1304,8 +1302,6 @@ package body Prj.Env is In_Tree : Project_Tree_Ref; Dummy : in out Integer) is - pragma Unreferenced (Dummy); - Current : String_List_Id := Prj.Source_Dirs; The_String : String_Element; @@ -1676,7 +1672,7 @@ package body Prj.Env is In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is - pragma Unreferenced (Dummy, In_Tree); + pragma Unreferenced (In_Tree); Path : Path_Name_Type; @@ -1908,8 +1904,6 @@ package body Prj.Env is Add_Default_Dir : Boolean := True; First : Positive; Last : Positive; - New_Len : Positive; - New_Last : Positive; Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; @@ -2047,17 +2041,14 @@ package body Prj.Env is Last := Last - 1; - elsif not Hostparm.OpenVMS - or else not Is_Absolute_Path (Name_Buffer (First .. Last)) - then - -- On VMS, only expand relative path names, as absolute paths - -- may correspond to multi-valued VMS logical names. - + else declare New_Dir : constant String := Normalize_Pathname (Name_Buffer (First .. Last), Resolve_Links => Opt.Follow_Links_For_Dirs); + New_Len : Positive; + New_Last : Positive; begin -- If the absolute path was resolved and is different from diff --git a/main/gcc/ada/prj-makr.adb b/main/gcc/ada/prj-makr.adb index 4f4ab43c08c..d58f4df9a1d 100644 --- a/main/gcc/ada/prj-makr.adb +++ b/main/gcc/ada/prj-makr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Csets; -with Hostparm; with Makeutl; use Makeutl; with Opt; with Output; @@ -1058,11 +1057,9 @@ package body Prj.Makr is Project_File_Extension; Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; - -- Back up project file if it already exists (not needed in VMS since - -- versioning of files takes care of this requirement on VMS). + -- Back up project file if it already exists - if not Hostparm.OpenVMS - and then not Opt.No_Backup + if not Opt.No_Backup and then Is_Regular_File (Path_Name (1 .. Path_Last)) then declare @@ -1280,15 +1277,6 @@ package body Prj.Makr is new String'(Get_Name_String (Tmp_File)); end if; - -- On VMS, a file created with Create_Temp_File cannot - -- be used to redirect output. - - if Hostparm.OpenVMS then - Close (FD); - Delete_File (Temp_File_Name.all, Success); - FD := Create_Output_Text_File (Temp_File_Name.all); - end if; - Args (Args'Last) := new String' (Dir_Name & Directory_Separator & diff --git a/main/gcc/ada/prj-nmsc.adb b/main/gcc/ada/prj-nmsc.adb index e6a1f4c601b..93b5963b644 100644 --- a/main/gcc/ada/prj-nmsc.adb +++ b/main/gcc/ada/prj-nmsc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Prj.Tree; use Prj.Tree; with Prj.Util; use Prj.Util; with Sinput.P; with Snames; use Snames; -with Targparm; use Targparm; with Ada; use Ada; with Ada.Characters.Handling; use Ada.Characters.Handling; @@ -547,12 +546,9 @@ package body Prj.Nmsc is while J <= Str'Last loop Name_Len := Name_Len + 1; - if J <= Max - and then Str (J .. J + Pattern'Length - 1) = Pattern - then + if J <= Max and then Str (J .. J + Pattern'Length - 1) = Pattern then Name_Buffer (Name_Len) := Replacement; J := J + Pattern'Length; - else Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J)); J := J + 1; @@ -738,8 +734,7 @@ package body Prj.Nmsc is -- the same file name in unrelated projects. elsif Is_Extending (Project, Source.Project) then - if not Locally_Removed - and then Naming_Exception /= Inherited + if not Locally_Removed and then Naming_Exception /= Inherited then Source_To_Replace := Source; end if; @@ -2403,7 +2398,8 @@ package body Prj.Nmsc is Lang_Index.Config.Toolchain_Version := Element.Value.Value; - -- For Ada, set proper checksum computation mode + -- For Ada, set proper checksum computation mode, + -- which has changed from version to version. if Lang_Index.Name = Name_Ada then declare @@ -2432,7 +2428,7 @@ package body Prj.Nmsc is then Checksum_GNAT_5_03 := True; - -- Version 5.02 or earlier + -- Version 5.02 or earlier (no checksums) if Vers (6) /= '5' or else Vers (Vers'Last) < '3' @@ -3031,6 +3027,87 @@ package body Prj.Nmsc is procedure Check_Library (Proj : Project_Id; Extends : Boolean); -- Check if an imported or extended project if also a library project + procedure Check_Aggregate_Library_Dirs; + -- Check that the library directory and the library ALI directory of an + -- aggregate library project are not the same as the object directory or + -- the library directory of any of its aggregated projects. + + ---------------------------------- + -- Check_Aggregate_Library_Dirs -- + ---------------------------------- + + procedure Check_Aggregate_Library_Dirs is + procedure Process_Aggregate (Proj : Project_Id); + -- Recursive procedure to check the aggregated projects, as they may + -- also be aggregated library projects. + + ----------------------- + -- Process_Aggregate -- + ----------------------- + + procedure Process_Aggregate (Proj : Project_Id) is + Agg : Aggregated_Project_List; + + begin + Agg := Proj.Aggregated_Projects; + while Agg /= null loop + Error_Msg_Name_1 := Agg.Project.Name; + + if Agg.Project.Qualifier /= Aggregate_Library + and then Project.Library_ALI_Dir.Name = + Agg.Project.Object_Directory.Name + then + Error_Msg + (Data.Flags, + "aggregate library 'A'L'I directory cannot be shared with" + & " object directory of aggregated project %%", + The_Lib_Kind.Location, Project); + + elsif Project.Library_ALI_Dir.Name = + Agg.Project.Library_Dir.Name + then + Error_Msg + (Data.Flags, + "aggregate library 'A'L'I directory cannot be shared with" + & " library directory of aggregated project %%", + The_Lib_Kind.Location, Project); + + elsif Agg.Project.Qualifier /= Aggregate_Library + and then Project.Library_Dir.Name = + Agg.Project.Object_Directory.Name + then + Error_Msg + (Data.Flags, + "aggregate library directory cannot be shared with" + & " object directory of aggregated project %%", + The_Lib_Kind.Location, Project); + + elsif Project.Library_Dir.Name = + Agg.Project.Library_Dir.Name + then + Error_Msg + (Data.Flags, + "aggregate library directory cannot be shared with" + & " library directory of aggregated project %%", + The_Lib_Kind.Location, Project); + end if; + + if Agg.Project.Qualifier = Aggregate_Library then + Process_Aggregate (Agg.Project); + end if; + + Agg := Agg.Next; + end loop; + end Process_Aggregate; + + -- Start of processing for Check_Aggregate_Library_Dirs + + begin + if Project.Qualifier = Aggregate_Library then + Process_Aggregate (Project); + end if; + end Check_Aggregate_Library_Dirs; + ------------------- -- Check_Library -- ------------------- @@ -3243,9 +3320,6 @@ package body Prj.Nmsc is (Data.Flags, "library directory { does not exist", Lib_Dir.Location, Project); - - else - Project.Library_Dir := No_Path_Information; end if; -- Checks for object/source directories @@ -3358,7 +3432,7 @@ package body Prj.Nmsc is Project.Library := Project.Library_Dir /= No_Path_Information - and then Project.Library_Name /= No_Name; + and then Project.Library_Name /= No_Name; if Project.Extends = No_Project then case Project.Qualifier is @@ -3751,6 +3825,13 @@ package body Prj.Nmsc is Continuation := Continuation_String'Access; end if; + -- Check that aggregated libraries do not share the aggregate + -- Library_ALI_Dir. + + if Project.Qualifier = Aggregate_Library then + Check_Aggregate_Library_Dirs; + end if; + if Project.Library and not Data.In_Aggregate_Lib then -- Record the library name @@ -5019,7 +5100,7 @@ package body Prj.Nmsc is Error_Msg_Warn := Project.Symbol_Data.Symbol_Policy /= Controlled - and then Project.Symbol_Data.Symbol_Policy /= Direct; + and then Project.Symbol_Data.Symbol_Policy /= Direct; Error_Msg (Data.Flags, @@ -5140,22 +5221,6 @@ package body Prj.Nmsc is Name_Len := The_Name'Length; Name_Buffer (1 .. Name_Len) := The_Name; - -- Special cases of children of packages A, G, I and S on VMS - - if OpenVMS_On_Target - and then Name_Len > 3 - and then Name_Buffer (2 .. 3) = "__" - and then - (Name_Buffer (1) = 'a' or else - Name_Buffer (1) = 'g' or else - Name_Buffer (1) = 'i' or else - Name_Buffer (1) = 's') - then - Name_Buffer (2) := '.'; - Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len); - Name_Len := Name_Len - 1; - end if; - Real_Name := Name_Find; if Is_Reserved (Real_Name) then @@ -5435,12 +5500,10 @@ package body Prj.Nmsc is No_Sources : constant Boolean := ((not Source_Files.Default and then Source_Files.Values = Nil_String) - or else - (not Source_Dirs.Default - and then Source_Dirs.Values = Nil_String) - or else - (not Languages.Default - and then Languages.Values = Nil_String)) + or else (not Source_Dirs.Default + and then Source_Dirs.Values = Nil_String) + or else (not Languages.Default + and then Languages.Values = Nil_String)) and then Project.Extends = No_Project; -- Start of processing for Get_Directories @@ -5505,6 +5568,7 @@ package body Prj.Nmsc is if not Dir_Exists and then not Project.Externally_Built then if Opt.Directories_Must_Exist_In_Projects then + -- The object directory does not exist, report an error if -- the project is not externally built. @@ -5514,9 +5578,6 @@ package body Prj.Nmsc is (Data.Flags, Data.Flags.Require_Obj_Dirs, "object directory { not found", Project.Location, Project); - - else - Project.Object_Directory := No_Path_Information; end if; end if; end if; @@ -5619,8 +5680,7 @@ package body Prj.Nmsc is pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); - if not Source_Files.Default - and then Source_Files.Values = Nil_String + if not Source_Files.Default and then Source_Files.Values = Nil_String then Project.Source_Dirs := Nil_String; @@ -5785,9 +5845,7 @@ package body Prj.Nmsc is -- A non empty, non comment line should contain a file name - if Last /= 0 - and then (Last = 1 or else Line (1 .. 2) /= "--") - then + if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Line (1 .. Last); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); @@ -5970,20 +6028,15 @@ package body Prj.Nmsc is -- In the standard GNAT naming scheme, check for special cases: children -- or separates of A, G, I or S, and run time sources. - if Is_Standard_GNAT_Naming (Naming) - and then Name_Len >= 3 - then + if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then declare S1 : constant Character := Name_Buffer (1); S2 : constant Character := Name_Buffer (2); S3 : constant Character := Name_Buffer (3); begin - if S1 = 'a' - or else S1 = 'g' - or else S1 = 'i' - or else S1 = 's' - then + if S1 = 'a' or else S1 = 'g' or else S1 = 'i' or else S1 = 's' then + -- Children or separates of packages A, G, I or S. These names -- are x__ ... or x~... (where x is a, g, i, or s). Both -- versions (x__... and x~...) are allowed in all platforms, @@ -6051,9 +6104,7 @@ package body Prj.Nmsc is end if; end if; - if Unit /= No_Name - and then Current_Verbosity = High - then + if Unit /= No_Name and then Current_Verbosity = High then case Kind is when Spec => Debug_Output ("spec of", Unit); when Impl => Debug_Output ("body of", Unit); @@ -6232,11 +6283,19 @@ package body Prj.Nmsc is exception when Use_Error => + + -- Output message with name of directory. Note that we + -- use the ~ insertion method here in case the name + -- has special characters in it. + + Error_Msg_Strlen := Full_Path_Name'Length; + Error_Msg_String (1 .. Error_Msg_Strlen) := + Full_Path_Name.all; Error_Msg (Data.Flags, - "could not create " & Create & - " directory " & Full_Path_Name.all, - Location, Project); + "could not create " & Create & " directory ~", + Location, + Project); end; end if; end if; @@ -6513,8 +6572,7 @@ package body Prj.Nmsc is if Project.Project.Extends = No_Project and then Project.Project.Object_Directory = Project.Project.Directory - and then - not (Project.Project.Qualifier = Aggregate_Library) + and then not (Project.Project.Qualifier = Aggregate_Library) then Project.Project.Object_Directory := No_Path_Information; end if; @@ -6644,7 +6702,9 @@ package body Prj.Nmsc is (Project.Source_Names, Source.File); if NL /= No_Name_Location and then not NL.Listed then + -- Remove the exception + Source_Names_Htable.Set (Project.Source_Names, Source.File, @@ -6989,9 +7049,7 @@ package body Prj.Nmsc is Source.Kind := Kind; - if Current_Verbosity = High - and then Source.File /= No_File - then + if Current_Verbosity = High and then Source.File /= No_File then Debug_Output ("override kind for " & Get_Name_String (Source.File) & " idx=" & Source.Index'Img @@ -7160,8 +7218,7 @@ package body Prj.Nmsc is -- A file name in a list must be a source of a language - if Data.Flags.Error_On_Unknown_Language - and then Name_Loc.Found + if Data.Flags.Error_On_Unknown_Language and then Name_Loc.Found then Error_Msg_File_1 := File_Name; Error_Msg @@ -7328,10 +7385,7 @@ package body Prj.Nmsc is Read (Dir, Name, Last); exit when Last = 0; - if Name (1 .. Last) /= "." - and then - Name (1 .. Last) /= ".." - then + if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then declare Path_Name : constant String := Normalize_Pathname @@ -7339,8 +7393,9 @@ package body Prj.Nmsc is Directory => Path_Str, Resolve_Links => Resolve_Links) & Directory_Separator; - Path2 : Path_Information; - OK : Boolean := True; + + Path2 : Path_Information; + OK : Boolean := True; begin if Is_Directory (Path_Name) then @@ -7452,8 +7507,8 @@ package body Prj.Nmsc is Pattern_End - 1 >= Pattern'First and then Pattern (Pattern_End - 1 .. Pattern_End) = "**" and then (Pattern_End - 1 = Pattern'First - or else Pattern (Pattern_End - 2) = '/' - or else Pattern (Pattern_End - 2) = Directory_Separator); + or else Pattern (Pattern_End - 2) = '/' + or else Pattern (Pattern_End - 2) = Directory_Separator); if Recursive then Pattern_End := Pattern_End - 2; @@ -7826,9 +7881,7 @@ package body Prj.Nmsc is Continuation : Boolean := False; Iter : Source_Iterator; begin - if not Project.Project.Externally_Built - and then not Extending - then + if not Project.Project.Externally_Built and then not Extending then Language := Project.Project.Languages; while Language /= No_Language_Index loop @@ -8143,11 +8196,9 @@ package body Prj.Nmsc is -- unit name is not null. if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then - declare UData : Unit_Index := - Units_Htable.Get - (Data.Tree.Units_HT, Src.Unit_Name); + Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name); begin if UData = No_Unit_Index then UData := new Unit_Data; @@ -8466,7 +8517,7 @@ package body Prj.Nmsc is Show_Source_Dirs (Project, Shared); end if; - if Project.Qualifier = Dry then + if Project.Qualifier = Abstract_Project then Check_Abstract_Project (Project, Data); end if; end case; diff --git a/main/gcc/ada/prj-pars.adb b/main/gcc/ada/prj-pars.adb index 7fbce49fa9a..a37e13aec93 100644 --- a/main/gcc/ada/prj-pars.adb +++ b/main/gcc/ada/prj-pars.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -103,8 +103,8 @@ package body Prj.Pars is Success := The_Project /= No_Project; exception - when Invalid_Config => - Success := False; + when E : Invalid_Config => + Osint.Fail (Exception_Message (E)); end; Prj.Err.Finalize; diff --git a/main/gcc/ada/prj-part.adb b/main/gcc/ada/prj-part.adb index 48b57aa454b..bc6a566e2ca 100644 --- a/main/gcc/ada/prj-part.adb +++ b/main/gcc/ada/prj-part.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1094,7 +1094,8 @@ package body Prj.Part is while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); - if Project_Qualifier_Of (Imported, In_Tree) /= Dry then + if Project_Qualifier_Of (Imported, In_Tree) /= Abstract_Project + then Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); Error_Msg (Flags, "can only import abstract projects, not %%", Token_Ptr); @@ -1152,7 +1153,7 @@ package body Prj.Part is Qualifier_Location := Token_Ptr; if Token = Tok_Abstract then - Proj_Qualifier := Dry; + Proj_Qualifier := Abstract_Project; Scan (In_Tree); elsif Token = Tok_Identifier then @@ -1370,7 +1371,8 @@ package body Prj.Part is if Extended then if A_Project_Name_And_Node.Extended then - if A_Project_Name_And_Node.Proj_Qualifier /= Dry then + if A_Project_Name_And_Node.Proj_Qualifier /= Abstract_Project + then Error_Msg (Env.Flags, "cannot extend the same project file several times", @@ -1811,8 +1813,11 @@ package body Prj.Part is -- with sources if it inherits sources from the project -- it extends. - if Project_Qualifier_Of (Project, In_Tree) = Dry and then - Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + if Project_Qualifier_Of (Project, In_Tree) = + Abstract_Project + and then + Project_Qualifier_Of (Extended_Project, In_Tree) /= + Abstract_Project then Error_Msg (Env.Flags, "an abstract project can only extend " & @@ -1925,7 +1930,8 @@ package body Prj.Part is Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); if Present (Extended_Project) - and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Dry + and then Project_Qualifier_Of (Extended_Project, In_Tree) /= + Abstract_Project then Set_Extending_Project_Of (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, diff --git a/main/gcc/ada/prj-pp.adb b/main/gcc/ada/prj-pp.adb index 15e3dcf651e..9ccd935f6af 100644 --- a/main/gcc/ada/prj-pp.adb +++ b/main/gcc/ada/prj-pp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +35,8 @@ package body Prj.PP is Not_Tested : array (Project_Node_Kind) of Boolean := (others => True); procedure Indicate_Tested (Kind : Project_Node_Kind); - -- Set the corresponding component of array Not_Tested to False. - -- Only called by pragmas Debug. + -- Set the corresponding component of array Not_Tested to False. Only + -- called by Debug pragmas. --------------------- -- Indicate_Tested -- @@ -84,14 +84,15 @@ package body Prj.PP is procedure Start_Line (Indent : Natural); -- Outputs the indentation at the beginning of the line + procedure Output_Project_File (S : Name_Id); + -- Output a project file name in one single string literal + procedure Output_String (S : Name_Id; Indent : Natural); - procedure Output_String (S : Path_Name_Type; Indent : Natural); -- Outputs a string using the default output procedures procedure Write_Empty_Line (Always : Boolean := False); -- Outputs an empty line, only if the previous line was not empty - -- already and either Always is True or Minimize_Empty_Lines is - -- False. + -- already and either Always is True or Minimize_Empty_Lines is False. procedure Write_Line (S : String); -- Outputs S followed by a new line @@ -100,12 +101,12 @@ package body Prj.PP is (S : String; Indent : Natural; Truncated : Boolean := False); - -- Outputs S using Write_Str, starting a new line if line would - -- become too long, when Truncated = False. - -- When Truncated = True, only the part of the string that can fit on - -- the line is output. + -- Outputs S using Write_Str, starting a new line if line would become + -- too long, when Truncated = False. When Truncated = True, only the + -- part of the string that can fit on the line is output. procedure Write_End_Of_Line_Comment (Node : Project_Node_Id); + -- Needs comment??? Write_Char : Write_Char_Ap := Output.Write_Char'Access; Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access; @@ -199,6 +200,28 @@ package body Prj.PP is Column := Column + Name_Len; end Output_Name; + ------------------------- + -- Output_Project_File -- + ------------------------- + + procedure Output_Project_File (S : Name_Id) is + File_Name : constant String := Get_Name_String (S); + + begin + Write_Char ('"'); + + for J in File_Name'Range loop + if File_Name (J) = '"' then + Write_Char ('"'); + Write_Char ('"'); + else + Write_Char (File_Name (J)); + end if; + end loop; + + Write_Char ('"'); + end Output_Project_File; + ------------------- -- Output_String -- ------------------- @@ -256,11 +279,6 @@ package body Prj.PP is Column := Column + 1; end Output_String; - procedure Output_String (S : Path_Name_Type; Indent : Natural) is - begin - Output_String (Name_Id (S), Indent); - end Output_String; - ---------------- -- Start_Line -- ---------------- @@ -323,15 +341,16 @@ package body Prj.PP is procedure Write_String (S : String; Indent : Natural; - Truncated : Boolean := False) is + Truncated : Boolean := False) + is Length : Natural := S'Length; + begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; - -- If the string would not fit on the line, - -- start a new line. + -- If the string would not fit on the line, start a new line if Column + Length > Max_Line_Length then if Truncated then @@ -358,9 +377,7 @@ package body Prj.PP is procedure Print (Node : Project_Node_Id; Indent : Natural) is begin if Present (Node) then - case Kind_Of (Node, In_Tree) is - when N_Project => pragma Debug (Indicate_Tested (N_Project)); if Present (First_With_Clause_Of (Node, In_Tree)) then @@ -386,7 +403,7 @@ package body Prj.PP is Write_String ("library ", Indent); when Configuration => Write_String ("configuration ", Indent); - when Dry => + when Abstract_Project => Write_String ("abstract ", Indent); end case; @@ -407,9 +424,8 @@ package body Prj.PP is Write_String ("all ", Indent); end if; - Output_String - (Extended_Project_Path_Of (Node, In_Tree), - Indent); + Output_Project_File + (Name_Id (Extended_Project_Path_Of (Node, In_Tree))); end if; Write_String (" is", Indent); @@ -440,9 +456,8 @@ package body Prj.PP is pragma Debug (Indicate_Tested (N_With_Clause)); -- The with clause will sometimes contain an invalid name - -- when we are importing a virtual project from an - -- extending all project. Do not output anything in this - -- case + -- when we are importing a virtual project from an extending + -- all project. Do not output anything in this case. if Name_Of (Node, In_Tree) /= No_Name and then String_Value_Of (Node, In_Tree) /= No_Name @@ -460,7 +475,10 @@ package body Prj.PP is Write_String ("with ", Indent); end if; - Output_String (String_Value_Of (Node, In_Tree), Indent); + -- Output the project name without concatenation, even if + -- the line is too long. + + Output_Project_File (String_Value_Of (Node, In_Tree)); if Is_Not_Last_In_List (Node, In_Tree) then Write_String (", ", Indent); @@ -522,8 +540,7 @@ package body Prj.PP is Print (First_Comment_After (Node, In_Tree), Indent + Increment); - if First_Declarative_Item_Of (Node, In_Tree) /= - Empty_Node + if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node then Print (First_Declarative_Item_Of (Node, In_Tree), @@ -557,8 +574,7 @@ package body Prj.PP is begin while Present (String_Node) loop Output_String - (String_Value_Of (String_Node, In_Tree), - Indent); + (String_Value_Of (String_Node, In_Tree), Indent); String_Node := Next_Literal_String (String_Node, In_Tree); @@ -579,8 +595,7 @@ package body Prj.PP is if Source_Index_Of (Node, In_Tree) /= 0 then Write_String (" at", Indent); Write_String - (Source_Index_Of (Node, In_Tree)'Img, - Indent); + (Source_Index_Of (Node, In_Tree)'Img, Indent); end if; when N_Attribute_Declaration => @@ -593,14 +608,12 @@ package body Prj.PP is if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then Write_String (" (", Indent); Output_String - (Associative_Array_Index_Of (Node, In_Tree), - Indent); + (Associative_Array_Index_Of (Node, In_Tree), Indent); if Source_Index_Of (Node, In_Tree) /= 0 then Write_String (" at", Indent); Write_String - (Source_Index_Of (Node, In_Tree)'Img, - Indent); + (Source_Index_Of (Node, In_Tree)'Img, Indent); end if; Write_String (")", Indent); @@ -614,17 +627,14 @@ package body Prj.PP is else -- Full associative array declaration - if - Present (Associative_Project_Of (Node, In_Tree)) - then + if Present (Associative_Project_Of (Node, In_Tree)) then Output_Name (Name_Of (Associative_Project_Of (Node, In_Tree), In_Tree), Indent); - if - Present (Associative_Package_Of (Node, In_Tree)) + if Present (Associative_Package_Of (Node, In_Tree)) then Write_String (".", Indent); Output_Name @@ -634,8 +644,7 @@ package body Prj.PP is Indent); end if; - elsif - Present (Associative_Package_Of (Node, In_Tree)) + elsif Present (Associative_Package_Of (Node, In_Tree)) then Output_Name (Name_Of @@ -705,7 +714,7 @@ package body Prj.PP is declare Expression : Project_Node_Id := - First_Expression_In_List (Node, In_Tree); + First_Expression_In_List (Node, In_Tree); begin while Present (Expression) loop @@ -783,7 +792,6 @@ package body Prj.PP is declare Index : constant Name_Id := Associative_Array_Index_Of (Node, In_Tree); - begin if Index /= No_Name then Write_String (" (", Indent); @@ -804,7 +812,7 @@ package body Prj.PP is while Present (Case_Item) loop if Present (First_Declarative_Item_Of (Case_Item, In_Tree)) - or else not Eliminate_Empty_Case_Constructions + or else not Eliminate_Empty_Case_Constructions then Is_Non_Empty := True; exit; @@ -819,8 +827,7 @@ package body Prj.PP is Start_Line (Indent); Write_String ("case ", Indent); Print - (Case_Variable_Reference_Of (Node, In_Tree), - Indent); + (Case_Variable_Reference_Of (Node, In_Tree), Indent); Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print @@ -867,6 +874,7 @@ package body Prj.PP is declare Label : Project_Node_Id := First_Choice_Of (Node, In_Tree); + begin while Present (Label) loop Print (Label, Indent); @@ -975,7 +983,8 @@ package body Prj.PP is procedure wpr (Project : Prj.Tree.Project_Node_Id; - In_Tree : Prj.Tree.Project_Node_Tree_Ref) is + In_Tree : Prj.Tree.Project_Node_Tree_Ref) + is begin Pretty_Print (Project, In_Tree, Backward_Compatibility => False); end wpr; diff --git a/main/gcc/ada/prj-proc.adb b/main/gcc/ada/prj-proc.adb index b7a34b39598..1fd71fc5dfd 100644 --- a/main/gcc/ada/prj-proc.adb +++ b/main/gcc/ada/prj-proc.adb @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P R J . P R O C -- +-- P R J . P R O C -- -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -118,9 +118,12 @@ package body Prj.Proc is -- of an expression and return it as a Variable_Value. function Imported_Or_Extended_Project_From - (Project : Project_Id; - With_Name : Name_Id) return Project_Id; - -- Find an imported or extended project of Project whose name is With_Name + (Project : Project_Id; + With_Name : Name_Id; + No_Extending : Boolean := False) return Project_Id; + -- Find an imported or extended project of Project whose name is With_Name. + -- When No_Extending is True, do not look for extending projects, returns + -- the exact project whose name is With_Name. function Package_From (Project : Project_Id; @@ -516,6 +519,8 @@ package body Prj.Proc is Last : String_List_Id := Nil_String; -- Reference to the last string elements in Result, when Kind is List + Current_Term_Kind : Project_Node_Kind; + begin Result.Project := Project; Result.Location := Location_Of (First_Term, From_Project_Node_Tree); @@ -525,8 +530,10 @@ package body Prj.Proc is The_Term := First_Term; while Present (The_Term) loop The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); + Current_Term_Kind := + Kind_Of (The_Current_Term, From_Project_Node_Tree); - case Kind_Of (The_Current_Term, From_Project_Node_Tree) is + case Current_Term_Kind is when N_Literal_String => @@ -697,6 +704,13 @@ package body Prj.Proc is Index : Name_Id := No_Name; begin + <> + The_Project := Project; + The_Package := Pkg; + The_Name := No_Name; + The_Variable_Id := No_Variable; + Index := No_Name; + if Present (Term_Project) and then Term_Project /= From_Project_Node then @@ -705,8 +719,9 @@ package body Prj.Proc is The_Name := Name_Of (Term_Project, From_Project_Node_Tree); The_Project := Imported_Or_Extended_Project_From - (Project => Project, - With_Name => The_Name); + (Project => Project, + With_Name => The_Name, + No_Extending => True); end if; if Present (Term_Package) then @@ -737,9 +752,7 @@ package body Prj.Proc is The_Name := Name_Of (The_Current_Term, From_Project_Node_Tree); - if Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Attribute_Reference - then + if Current_Term_Kind = N_Attribute_Reference then Index := Associative_Array_Index_Of (The_Current_Term, From_Project_Node_Tree); @@ -755,9 +768,7 @@ package body Prj.Proc is -- First, if there is a package, look into the package - if Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Variable_Reference - then + if Current_Term_Kind = N_Variable_Reference then The_Variable_Id := Shared.Packages.Table (The_Package).Decl.Variables; @@ -782,9 +793,7 @@ package body Prj.Proc is -- If we have not found it, look into the project - if Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Variable_Reference - then + if Current_Term_Kind = N_Variable_Reference then The_Variable_Id := The_Project.Decl.Variables; else The_Variable_Id := The_Project.Decl.Attributes; @@ -878,8 +887,65 @@ package body Prj.Proc is end; end if; - case Kind is + -- Check the defaults + + if Current_Term_Kind = N_Attribute_Reference + and then The_Variable.Default + then + declare + The_Default : constant Attribute_Default_Value := + Default_Of + (The_Current_Term, From_Project_Node_Tree); + + begin + case The_Variable.Kind is + when Undefined => + null; + + when Single => + case The_Default is + when Read_Only_Value => + null; + + when Empty_Value => + The_Variable.Value := Empty_String; + + when Dot_Value => + The_Variable.Value := Dot_String; + + when Object_Dir_Value => + From_Project_Node_Tree.Project_Nodes.Table + (The_Current_Term).Name := + Snames.Name_Object_Dir; + From_Project_Node_Tree.Project_Nodes.Table + (The_Current_Term).Default := + Dot_Value; + goto Object_Dir_Restart; + + when Target_Value => + null; + end case; + + when List => + case The_Default is + when Read_Only_Value => + null; + when Empty_Value => + The_Variable.Values := Nil_String; + + when Dot_Value => + The_Variable.Values := + Shared.Dot_String_List; + + when Object_Dir_Value | Target_Value => + null; + end case; + end case; + end; + end if; + + case Kind is when Undefined => -- Should never happen @@ -888,7 +954,6 @@ package body Prj.Proc is null; when Single => - case The_Variable.Kind is when Undefined => @@ -1261,8 +1326,9 @@ package body Prj.Proc is --------------------------------------- function Imported_Or_Extended_Project_From - (Project : Project_Id; - With_Name : Name_Id) return Project_Id + (Project : Project_Id; + With_Name : Name_Id; + No_Extending : Boolean := False) return Project_Id is List : Project_List; Result : Project_Id; @@ -1304,7 +1370,12 @@ package body Prj.Proc is Proj := Result.Extends; while Proj /= No_Project loop if Proj.Name = With_Name then - Temp_Result := Result; + if No_Extending then + Temp_Result := Proj; + else + Temp_Result := Result; + end if; + exit; end if; @@ -2835,20 +2906,43 @@ package body Prj.Proc is return; end if; - Project := - new Project_Data' - (Empty_Project - (Project_Qualifier_Of - (From_Project_Node, From_Project_Node_Tree))); + -- Check if the project is already in the tree - -- Note that at this point we do not know yet if the project has - -- been withed from an encapsulated library or not. + Project := No_Project; - In_Tree.Projects := - new Project_List_Element' - (Project => Project, - From_Encapsulated_Lib => False, - Next => In_Tree.Projects); + declare + List : Project_List := In_Tree.Projects; + Path : constant Path_Name_Type := + Path_Name_Of (From_Project_Node, + From_Project_Node_Tree); + + begin + while List /= null loop + if List.Project.Path.Display_Name = Path then + Project := List.Project; + exit; + end if; + + List := List.Next; + end loop; + end; + + if Project = No_Project then + Project := + new Project_Data' + (Empty_Project + (Project_Qualifier_Of + (From_Project_Node, From_Project_Node_Tree))); + + -- Note that at this point we do not know yet if the project + -- has been withed from an encapsulated library or not. + + In_Tree.Projects := + new Project_List_Element' + (Project => Project, + From_Encapsulated_Lib => False, + Next => In_Tree.Projects); + end if; -- Keep track of this point @@ -2898,7 +2992,7 @@ package body Prj.Proc is Process_Imported_Projects (Imported, Limited_With => False); - if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then + if Project.Qualifier = Aggregate then Initialize_And_Copy (Child_Env, Copy_From => Env); elsif Project.Qualifier = Aggregate_Library then diff --git a/main/gcc/ada/prj-proc.ads b/main/gcc/ada/prj-proc.ads index 97d7310dda7..2b0680ebe52 100644 --- a/main/gcc/ada/prj-proc.ads +++ b/main/gcc/ada/prj-proc.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- P R J . P R O C -- +-- P R J . P R O C -- -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/prj-strt.adb b/main/gcc/ada/prj-strt.adb index 271a913e762..a6b0b381ff2 100644 --- a/main/gcc/ada/prj-strt.adb +++ b/main/gcc/ada/prj-strt.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -217,7 +217,10 @@ package body Prj.Strt is Set_Case_Insensitive (Reference, In_Tree, To => Attribute_Kind_Of (Current_Attribute) in - All_Case_Insensitive_Associative_Array); + All_Case_Insensitive_Associative_Array); + Set_Default_Of + (Reference, In_Tree, + To => Attribute_Default_Of (Current_Attribute)); -- Scan past the attribute name @@ -292,18 +295,21 @@ package body Prj.Strt is --------------------------- procedure End_Case_Construction - (Check_All_Labels : Boolean; - Case_Location : Source_Ptr; - Flags : Processing_Flags) + (Check_All_Labels : Boolean; + Case_Location : Source_Ptr; + Flags : Processing_Flags; + String_Type : Boolean) is - Non_Used : Natural := 0; + Non_Used : Natural := 0; First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; + begin - -- First, if Check_All_Labels is True, check if all values - -- of the string type have been used. + -- First, if Check_All_Labels is True, check if all values of the string + -- type have been used. if Check_All_Labels then - for Choice in Choice_First .. Choices.Last loop + if String_Type then + for Choice in Choice_First .. Choices.Last loop if not Choices.Table (Choice).Already_Used then Non_Used := Non_Used + 1; @@ -311,27 +317,34 @@ package body Prj.Strt is First_Non_Used := Choice; end if; end if; - end loop; + end loop; + + -- If only one is not used, report a single warning for this value - -- If only one is not used, report a single warning for this value + if Non_Used = 1 then + Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; + Error_Msg + (Flags, "?value %% is not used as label", Case_Location); - if Non_Used = 1 then - Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; - Error_Msg (Flags, "?value %% is not used as label", Case_Location); + -- If several are not used, report a warning for each one of them - -- If several are not used, report a warning for each one of them + elsif Non_Used > 1 then + Error_Msg + (Flags, "?the following values are not used as labels:", + Case_Location); - elsif Non_Used > 1 then + for Choice in First_Non_Used .. Choices.Last loop + if not Choices.Table (Choice).Already_Used then + Error_Msg_Name_1 := Choices.Table (Choice).The_String; + Error_Msg (Flags, "\?%%", Case_Location); + end if; + end loop; + end if; + else Error_Msg - (Flags, "?the following values are not used as labels:", + (Flags, + "?no when others for this case construction", Case_Location); - - for Choice in First_Non_Used .. Choices.Last loop - if not Choices.Table (Choice).Already_Used then - Error_Msg_Name_1 := Choices.Table (Choice).The_String; - Error_Msg (Flags, "\?%%", Case_Location); - end if; - end loop; end if; end if; @@ -342,18 +355,15 @@ package body Prj.Strt is Choices.Set_Last (First_Choice_Node_Id); Choice_First := 0; - elsif Choice_Lasts.Last = 2 then - - -- This is the second case construction, set the tables to the first + -- Second case construction, set the tables to the first + elsif Choice_Lasts.Last = 2 then Choice_Lasts.Set_Last (1); Choices.Set_Last (Choice_Lasts.Table (1)); Choice_First := 1; + -- Third or more case construction, set the tables to the previous one else - -- This is the 3rd or more case construction, set the tables to the - -- previous one. - Choice_Lasts.Decrement_Last; Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last)); Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1; @@ -427,7 +437,6 @@ package body Prj.Strt is Scan (In_Tree); case Token is - when Tok_Right_Paren => if Ext_List then Error_Msg (Flags, "`,` expected", Token_Ptr); @@ -484,7 +493,8 @@ package body Prj.Strt is procedure Parse_Choice_List (In_Tree : Project_Node_Tree_Ref; First_Choice : out Project_Node_Id; - Flags : Processing_Flags) + Flags : Processing_Flags; + String_Type : Boolean := True) is Current_Choice : Project_Node_Id := Empty_Node; Next_Choice : Project_Node_Id := Empty_Node; @@ -514,38 +524,41 @@ package body Prj.Strt is Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String); - -- Check if the label is part of the string type and if it has not - -- been already used. + if String_Type then - Found := False; - for Choice in Choice_First .. Choices.Last loop - if Choices.Table (Choice).The_String = Choice_String then + -- Check if the label is part of the string type and if it has not + -- been already used. - -- This label is part of the string type + Found := False; + for Choice in Choice_First .. Choices.Last loop + if Choices.Table (Choice).The_String = Choice_String then - Found := True; + -- This label is part of the string type - if Choices.Table (Choice).Already_Used then + Found := True; - -- But it has already appeared in a choice list for this - -- case construction so report an error. + if Choices.Table (Choice).Already_Used then - Error_Msg_Name_1 := Choice_String; - Error_Msg (Flags, "duplicate case label %%", Token_Ptr); + -- But it has already appeared in a choice list for this + -- case construction so report an error. - else - Choices.Table (Choice).Already_Used := True; - end if; + Error_Msg_Name_1 := Choice_String; + Error_Msg (Flags, "duplicate case label %%", Token_Ptr); - exit; - end if; - end loop; + else + Choices.Table (Choice).Already_Used := True; + end if; - -- If the label is not part of the string list, report an error + exit; + end if; + end loop; + + -- If the label is not part of the string list, report an error - if not Found then - Error_Msg_Name_1 := Choice_String; - Error_Msg (Flags, "illegal case label %%", Token_Ptr); + if not Found then + Error_Msg_Name_1 := Choice_String; + Error_Msg (Flags, "illegal case label %%", Token_Ptr); + end if; end if; -- Scan past the label @@ -1162,7 +1175,7 @@ package body Prj.Strt is -- If we have not found the variable in the package, check if the -- variable has been declared in the project, or in any of its - -- ancestors. + -- ancestors, or in any of the project it extends. if No (Current_Variable) then declare @@ -1182,7 +1195,19 @@ package body Prj.Strt is exit when Present (Current_Variable); - Proj := Parent_Project_Of (Proj, In_Tree); + -- If the current project is a child project, check if + -- the variable is declared in its parent. Otherwise, if + -- the current project extends another project, check if + -- the variable is declared in one of the projects the + -- current project extends. + + if No (Parent_Project_Of (Proj, In_Tree)) then + Proj := + Extended_Project_Of + (Project_Declaration_Of (Proj, In_Tree), In_Tree); + else + Proj := Parent_Project_Of (Proj, In_Tree); + end if; Set_Project_Node_Of (Variable, In_Tree, To => Proj); diff --git a/main/gcc/ada/prj-strt.ads b/main/gcc/ada/prj-strt.ads index 7dbe5302781..ab43346ef57 100644 --- a/main/gcc/ada/prj-strt.ads +++ b/main/gcc/ada/prj-strt.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,28 @@ private package Prj.Strt is procedure Start_New_Case_Construction (In_Tree : Project_Node_Tree_Ref; String_Type : Project_Node_Id); - -- This procedure is called at the beginning of a case construction The + -- This procedure is called at the beginning of a case construction. The -- parameter String_Type is the node for the string type of the case label -- variable. The different literal strings of the string type are stored - -- into a table to be checked against the case labels of the case - -- construction. + -- into a table to be checked against the labels of the case construction. procedure End_Case_Construction - (Check_All_Labels : Boolean; - Case_Location : Source_Ptr; - Flags : Processing_Flags); - -- This procedure is called at the end of a case construction to remove the - -- case labels and to restore the previous state. In particular, in the + (Check_All_Labels : Boolean; + Case_Location : Source_Ptr; + Flags : Processing_Flags; + String_Type : Boolean); + -- This procedure is called at the end of a case construction to remove + -- the case labels and to restore the previous state. In particular, in the -- case of nested case constructions, the case labels of the enclosing case - -- construction are restored. When When_Others is False and we are not in + -- construction are restored. If When_Others is False and we are not in -- quiet output, a warning is emitted for each value of the case variable -- string type that has not been specified. procedure Parse_Choice_List (In_Tree : Project_Node_Tree_Ref; First_Choice : out Project_Node_Id; - Flags : Processing_Flags); + Flags : Processing_Flags; + String_Type : Boolean := True); -- Get the label for a choice list. -- Report an error if -- - a case label is not a literal string diff --git a/main/gcc/ada/prj-tree.adb b/main/gcc/ada/prj-tree.adb index 2ff5a9fff18..023947c4e97 100644 --- a/main/gcc/ada/prj-tree.adb +++ b/main/gcc/ada/prj-tree.adb @@ -122,6 +122,7 @@ package body Prj.Tree is Src_Index => 0, Path_Name => No_Path, Value => No_Name, + Default => Empty_Value, Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, @@ -172,6 +173,7 @@ package body Prj.Tree is Src_Index => 0, Path_Name => No_Path, Value => Comments.Table (J).Value, + Default => Empty_Value, Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, @@ -340,6 +342,7 @@ package body Prj.Tree is Src_Index => 0, Path_Name => No_Path, Value => No_Name, + Default => Empty_Value, Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, @@ -385,6 +388,22 @@ package body Prj.Tree is return In_Tree.Project_Nodes.Table (Node).Field1; end Current_Term; + ---------------- + -- Default_Of -- + ---------------- + + function Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference); + return In_Tree.Project_Nodes.Table (Node).Default; + end Default_Of; + -------------------------- -- Default_Project_Node -- -------------------------- @@ -416,6 +435,7 @@ package body Prj.Tree is Src_Index => 0, Path_Name => No_Path, Value => No_Name, + Default => Empty_Value, Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, @@ -452,6 +472,7 @@ package body Prj.Tree is Src_Index => 0, Path_Name => No_Path, Value => No_Name, + Default => Empty_Value, Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, @@ -486,6 +507,7 @@ package body Prj.Tree is Src_Index => 0, Path_Name => No_Path, Value => Comments.Table (J).Value, + Default => Empty_Value, Field1 => Empty_Node, Field2 => Empty_Node, Field3 => Empty_Node, @@ -1867,6 +1889,23 @@ package body Prj.Tree is In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Current_Term; + -------------------- + -- Set_Default_Of -- + -------------------- + + procedure Set_Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Attribute_Default_Value) + is + begin + pragma Assert + (Present (Node) + and then + In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference); + In_Tree.Project_Nodes.Table (Node).Default := To; + end Set_Default_Of; + ---------------------- -- Set_Directory_Of -- ---------------------- diff --git a/main/gcc/ada/prj-tree.ads b/main/gcc/ada/prj-tree.ads index 0a7da7f20ef..e798d6b6700 100644 --- a/main/gcc/ada/prj-tree.ads +++ b/main/gcc/ada/prj-tree.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -590,6 +590,12 @@ package Prj.Tree is -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. -- May return Empty_Node. + function Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value; + pragma Inline (Default_Of); + -- Only valid for N_Attribute_Reference nodes + function String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; @@ -1068,7 +1074,14 @@ package Prj.Tree is In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Package_Node_Of); - -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. + -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes + + procedure Set_Default_Of + (Node : Project_Node_Id; + In_Tree : Project_Node_Tree_Ref; + To : Attribute_Default_Value); + pragma Inline (Set_Default_Of); + -- Only valid for N_Attribute_Reference nodes procedure Set_String_Type_Of (Node : Project_Node_Id; @@ -1179,6 +1192,9 @@ package Prj.Tree is Value : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used + Default : Attribute_Default_Value := Empty_Value; + -- Only used in N_Attribute_Reference + Field1 : Project_Node_Id := Empty_Node; -- See below the meaning for each Project_Node_Kind diff --git a/main/gcc/ada/prj-util.adb b/main/gcc/ada/prj-util.adb index d369ae2494e..447818daf34 100644 --- a/main/gcc/ada/prj-util.adb +++ b/main/gcc/ada/prj-util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -467,7 +467,8 @@ package body Prj.Util is -- the interface for standalone libraries. if Sid.Kind = Spec - and then not Sid.Project.Externally_Built + and then (not Sid.Project.Externally_Built + or else Sid.Project = Project) and then not Sid.Locally_Removed and then (Project.Standalone_Library = No or else Sid.Declared_In_Interfaces) diff --git a/main/gcc/ada/prj.adb b/main/gcc/ada/prj.adb index 808325e3905..88196e10f41 100644 --- a/main/gcc/ada/prj.adb +++ b/main/gcc/ada/prj.adb @@ -23,7 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Debug; with Opt; with Osint; use Osint; with Output; use Output; @@ -61,6 +60,7 @@ package body Prj is -- Initial size for extensible buffer used in Add_To_Buffer The_Empty_String : Name_Id := No_Name; + The_Dot_String : Name_Id := No_Name; Debug_Level : Integer := 0; -- Current indentation level for debug traces @@ -141,8 +141,7 @@ package body Prj is while Last + S'Length > To'Last loop declare New_Buffer : constant String_Access := - new String (1 .. 2 * Last); - + new String (1 .. 2 * To'Length); begin New_Buffer (1 .. Last) := To (1 .. Last); Free (To); @@ -188,7 +187,7 @@ package body Prj is pragma Warnings (Off, Dont_Care); begin - if not Debug.Debug_Flag_N then + if not Opt.Keep_Temporary_Files then if Current_Verbosity = High then Write_Line ("Removing temp file: " & Get_Name_String (Path)); end if; @@ -218,7 +217,7 @@ package body Prj is Proj : Project_List; begin - if not Debug.Debug_Flag_N then + if not Opt.Keep_Temporary_Files then if Project_Tree /= null then Proj := Project_Tree.Projects; while Proj /= null loop @@ -255,7 +254,7 @@ package body Prj is Path : Path_Name_Type; begin - if not Debug.Debug_Flag_N then + if not Opt.Keep_Temporary_Files then for Index in 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files) loop @@ -277,8 +276,7 @@ package body Prj is -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to - -- the empty string. On VMS, this has the effect of deassigning - -- the logical names. + -- the empty string. if Shared.Private_Part.Current_Source_Path_File /= No_Path then Setenv (Project_Include_Path_File, ""); @@ -311,6 +309,15 @@ package body Prj is end Dependency_Name; ---------------- + -- Dot_String -- + ---------------- + + function Dot_String return Name_Id is + begin + return The_Dot_String; + end Dot_String; + + ---------------- -- Empty_File -- ---------------- @@ -1060,6 +1067,10 @@ package body Prj is Name_Len := 0; The_Empty_String := Name_Find; + Name_Len := 1; + Name_Buffer (1) := '.'; + The_Dot_String := Name_Find; + Prj.Attr.Initialize; -- Make sure that new reserved words after Ada 95 may be used as @@ -1445,6 +1456,20 @@ package body Prj is Array_Table.Init (Tree.Shared.Arrays); Package_Table.Init (Tree.Shared.Packages); + -- Create Dot_String_List + + String_Element_Table.Append + (Tree.Shared.String_Elements, + String_Element' + (Value => The_Dot_String, + Index => 0, + Display_Value => The_Dot_String, + Location => No_Location, + Flag => False, + Next => Nil_String)); + Tree.Shared.Dot_String_List := + String_Element_Table.Last (Tree.Shared.String_Elements); + -- Private part table Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files); @@ -1715,7 +1740,7 @@ package body Prj is Context : Project_Context; Dummy : in out Boolean) is - pragma Unreferenced (Dummy, Tree); + pragma Unreferenced (Tree); List : Project_List; Prj2 : Project_Id; @@ -2102,7 +2127,7 @@ package body Prj is if Project.Qualifier in Aggregate_Project then Ctx := - (In_Aggregate_Lib => True, + (In_Aggregate_Lib => Project.Qualifier = Aggregate_Library, From_Encapsulated_Lib => Context.From_Encapsulated_Lib or else Project.Standalone_Library = Encapsulated); diff --git a/main/gcc/ada/prj.ads b/main/gcc/ada/prj.ads index ce6e01e7e16..1beff66a9da 100644 --- a/main/gcc/ada/prj.ads +++ b/main/gcc/ada/prj.ads @@ -72,6 +72,15 @@ package Prj is type Yes_No_Unknown is (Yes, No, Unknown); -- Tri-state to decide if -lgnarl is needed when linking + type Attribute_Default_Value is + (Read_Only_Value, -- For read only attributes (Name, Project_Dir) + Empty_Value, -- Empty string or empty string list + Dot_Value, -- "." or (".") + Object_Dir_Value, -- 'Object_Dir + Target_Value); -- 'Target (special rules) + -- Describe the default values of attributes that are referenced but not + -- declared. + pragma Warnings (Off); type Project_Qualifier is (Unspecified, @@ -83,7 +92,7 @@ package Prj is Library, Configuration, - Dry, + Abstract_Project, Aggregate, Aggregate_Library); pragma Warnings (On); @@ -91,7 +100,7 @@ package Prj is -- file: -- Standard: standard project ... -- Library: library project is ... - -- Dry: abstract project is + -- Abstract_Project: abstract project is -- Aggregate: aggregate project is -- Aggregate_Library: aggregate library project is ... -- Configuration: configuration project is ... @@ -123,6 +132,9 @@ package Prj is function Empty_String return Name_Id; -- Return the id for an empty string "" + function Dot_String return Name_Id; + -- Return the id for "." + type Path_Information is record Name : Path_Name_Type := No_Path; Display_Name : Path_Name_Type := No_Path; @@ -441,10 +453,8 @@ package Prj is No_Source : constant Source_Id := null; type Path_Syntax_Kind is - (Canonical, - -- Unix style - Host); - -- Host specific syntax, for example on VMS (the default) + (Canonical, -- Unix style + Host); -- Host specific syntax -- The following record describes the configuration of a language @@ -484,8 +494,7 @@ package Prj is -- unit in a multi-source file, in the object file name. Path_Syntax : Path_Syntax_Kind := Host; - -- Value may be Canonical (Unix style) or Host (host syntax, for example - -- on VMS for DEC C). + -- Value may be Canonical (Unix style) or Host (host syntax) Source_File_Switches : Name_List_Index := No_Name_List; -- Optional switches to be put before the source file. The source file @@ -1573,6 +1582,7 @@ package Prj is Arrays : Array_Table.Instance; Packages : Package_Table.Instance; Private_Part : Private_Project_Tree_Data; + Dot_String_List : String_List_Id := Nil_String; end record; type Shared_Project_Tree_Data_Access is access all Shared_Project_Tree_Data; -- The data that is shared among multiple trees, when these trees are @@ -1882,10 +1892,11 @@ package Prj is -- * user project also includes a "with" that can only be resolved -- once we have found the gnatls - Gprbuild_Flags : constant Processing_Flags; - Gprclean_Flags : constant Processing_Flags; - Gprexec_Flags : constant Processing_Flags; - Gnatmake_Flags : constant Processing_Flags; + Gprbuild_Flags : constant Processing_Flags; + Gprinstall_Flags : constant Processing_Flags; + Gprclean_Flags : constant Processing_Flags; + Gprexec_Flags : constant Processing_Flags; + Gnatmake_Flags : constant Processing_Flags; -- Flags used by the various tools. They all display the error messages -- through Prj.Err. @@ -1951,7 +1962,6 @@ package Prj is -- indentation level only affects output done through Debug_Output. private - All_Packages : constant String_List_Access := null; No_Project_Tree : constant Project_Tree_Ref := null; @@ -1991,14 +2001,18 @@ private Last : in out Natural); -- Append a String to the Buffer + -- Table used to store the path name of all the created temporary files, so + -- that they can be deleted at the end, or when the program is interrupted. + package Temp_Files_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Path_Name_Type, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 10); - -- Table to store the path name of all the created temporary files, so that - -- they can be deleted at the end, or when the program is interrupted. + + -- The following type is used to represent the part of a project tree which + -- is private to the Project Manager. type Private_Project_Tree_Data is record Temp_Files : Temp_Files_Table.Instance; @@ -2008,18 +2022,17 @@ private Current_Source_Path_File : Path_Name_Type := No_Path; -- Current value of project source path file env var. Used to avoid -- setting the env var to the same value. When different from No_Path, - -- this indicates that logical names (VMS) or environment variables were - -- created and should be deassigned to avoid polluting the environment - -- on VMS. This is for gnatmake only. + -- this indicates that environment variables were created and should be + -- deassigned to avoid polluting the environment. For gnatmake only. Current_Object_Path_File : Path_Name_Type := No_Path; -- Current value of project object path file env var. Used to avoid -- setting the env var to the same value. -- gnatmake only - end record; - -- Type to represent the part of a project tree which is private to the - -- Project Manager. + + -- The following type is used to hold processing flags which show what + -- functions are required for the various tools that are handled. type Processing_Flags is record Require_Sources_Other_Lang : Boolean; @@ -2034,52 +2047,64 @@ private Ignore_Missing_With : Boolean; end record; - Gprbuild_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Warning, - Require_Sources_Other_Lang => True, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => True, - Error_On_Unknown_Language => True, - Require_Obj_Dirs => Error, - Allow_Invalid_External => Error, - Missing_Source_Files => Error, - Ignore_Missing_With => False); - - Gprclean_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Warning, - Require_Sources_Other_Lang => True, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => True, - Error_On_Unknown_Language => True, - Require_Obj_Dirs => Warning, - Allow_Invalid_External => Error, - Missing_Source_Files => Error, - Ignore_Missing_With => False); - - Gprexec_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Silent, - Require_Sources_Other_Lang => False, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => False, - Error_On_Unknown_Language => True, - Require_Obj_Dirs => Silent, - Allow_Invalid_External => Error, - Missing_Source_Files => Silent, - Ignore_Missing_With => False); - - Gnatmake_Flags : constant Processing_Flags := - (Report_Error => null, - When_No_Sources => Error, - Require_Sources_Other_Lang => False, - Allow_Duplicate_Basenames => False, - Compiler_Driver_Mandatory => False, - Error_On_Unknown_Language => False, - Require_Obj_Dirs => Error, - Allow_Invalid_External => Error, - Missing_Source_Files => Error, - Ignore_Missing_With => False); + Gprbuild_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); + + Gprinstall_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Silent, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); + + Gprclean_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Warning, + Require_Sources_Other_Lang => True, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => True, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Warning, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); + + Gprexec_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Silent, + Require_Sources_Other_Lang => False, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => False, + Error_On_Unknown_Language => True, + Require_Obj_Dirs => Silent, + Allow_Invalid_External => Error, + Missing_Source_Files => Silent, + Ignore_Missing_With => False); + + Gnatmake_Flags : constant Processing_Flags := + (Report_Error => null, + When_No_Sources => Error, + Require_Sources_Other_Lang => False, + Allow_Duplicate_Basenames => False, + Compiler_Driver_Mandatory => False, + Error_On_Unknown_Language => False, + Require_Obj_Dirs => Error, + Allow_Invalid_External => Error, + Missing_Source_Files => Error, + Ignore_Missing_With => False); end Prj; diff --git a/main/gcc/ada/projects.texi b/main/gcc/ada/projects.texi index e23f9fadd83..06e3ac6796b 100644 --- a/main/gcc/ada/projects.texi +++ b/main/gcc/ada/projects.texi @@ -1,7 +1,7 @@ @set gprconfig GPRconfig @c ------ projects.texi -@c Copyright (C) 2002-2013, Free Software Foundation, Inc. +@c Copyright (C) 2002-2014, Free Software Foundation, Inc. @c This file is shared between the GNAT user's guide and gprbuild. It is not @c compilable on its own, you should instead compile the other two manuals. @c For that reason, there is no toplevel @menu @@ -41,7 +41,7 @@ project files allow you to specify: @item The directory in which the compiler's output (@file{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^Switch^ settings for any of the project-enabled tools; +@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) @@ -68,7 +68,7 @@ Subsystems}). 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^switch^ settings) used for different subsystems. + (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 @@ -80,8 +80,8 @@ Subsystems}). 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 -@option{^-P^/PROJECT_FILE=^@emph{projectfile}} and -@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}}). +@option{-P@emph{projectfile}} and +@option{-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 @@ -89,15 +89,14 @@ easily handled: @itemize @bullet @item Using a common set of source files and generating object files in different - directories via different ^switch^switch^ settings. It can be used for instance, for + 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 @noindent -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 @@ -174,7 +173,6 @@ detailed later in this documentation. They are summarized here as a reference. @b{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. -/first exam @end table @@ -185,19 +183,19 @@ 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 @code{Proc} that @code{with}s package @code{Pack}. We want to compile -these source files with the ^switch^switch^ -@option{^-O2^-O2^}, and put the resulting files in +these source files with the switch +@option{-O2}, and put the resulting files in the directory @file{obj/}. @smallexample @group -^common/^[COMMON]^ +common/ pack.ads pack.adb proc.adb @end group @group -^common/release/^[COMMON.RELEASE]^ +common/obj/ proc.ali, proc.o pack.ali, pack.o @end group @end smallexample @@ -238,12 +236,12 @@ should contain the following code: @noindent When you create a new project, the first thing to describe is how to find the -corresponding source files. This is the only settings that are needed by all +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,@dots{}). @cindex Source directories -First step is to declare the source directories, which are the directories +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. @@ -266,15 +264,16 @@ There are several ways of defining source directories: @cindex portability 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 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 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 @b{Source_Dirs} can automatically include subdirectories - using a special syntax inspired by some UNIX shells. If any of the path in - the list ends with @emph{"**"}, then that path and all its 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 ".". + @file{**} and @file{./**} represent the complete directory tree rooted at + the directory in which the project file resides. @cindex Source directories, recursive @cindex @code{Excluded_Source_Dirs} @@ -321,7 +320,7 @@ their absolute or relative path names. The project manager is in charge of locating the specified source files in the specified source directories. @itemize @bullet -@item By default, the project manager search for all source files of all +@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 @@ -415,15 +414,14 @@ to it and this is not explicitly indicated in the project file. @noindent If the order of the source directories is known statically, that is if @code{"/**"} is not used in the string list @code{Source_Dirs}, then there may -be several files with the same source file 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 -@code{"/**"} is used in the string list @code{Source_Dirs}, it is an error -to have several files with the same source file name in the same directory -@code{"/**"} subtree, since there would be an ambiguity as to which one should -be used. However, two files with the same source file 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. +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 @code{"/**"} is used in the +string list @code{Source_Dirs}, it is an error to have several files with the +same name in the same directory @code{"/**"} 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 @code{"/**"} subtree, one way to resolve the problem is to exclude the directory of the @@ -450,7 +448,7 @@ 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 @code{^-p^/CREATE_MISSING_DIRS^} for @command{gnatmake} +the switch @code{-p} for @command{gnatmake} and @command{gprbuild}). If the attribute @code{Object_Dir} is not specified, it defaults to @@ -467,11 +465,11 @@ For our example, we can specify the object dir in this way: @noindent 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 in +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 (@pxref{Organizing Projects into Subsystems}) to see how each -separate object directory can be associated with one of the subsystem +separate object directory can be associated with one of the subsystems constituting the application. When the @command{linker} is called, it usually creates an executable. By @@ -506,7 +504,7 @@ the project file is now @noindent 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 source file of the main subprogram. In C this is the file that +pointing to the source file of a main subprogram. In C this is the file that contains the @code{main} function, and in Ada the file that contains the main unit. @@ -515,8 +513,8 @@ 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 @command{makefile}, one does not need to specify the list of -dependencies of each executable, the project-aware builders knows enough of the -semantics of the languages to build ands link only the necessary elements. +dependencies of each executable, the project-aware builder knows enough of the +semantics of the languages to build and link only the necessary elements. @cindex @code{Main} The list of main files is specified via the @b{Main} attribute. It contains @@ -540,7 +538,7 @@ If this attribute is defined in the project, then spawning the builder with a command such as @smallexample - gnatmake ^-Pbuild^/PROJECT_FILE=build^ + gprbuild -Pbuild @end smallexample @noindent @@ -555,32 +553,31 @@ or more executables on the command line to build a subset of them. @noindent We now have a project file that fully describes our environment, and can be -used to build the application with a simple @command{gnatmake} command as seen +used to build the application with a simple @command{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 always want more control. This section will show you how to -specify the compilation switches that the various tools involved in the -building of the executable should use. +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. @cindex command line length -Since source names and locations are described into the project file, it is not +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 should not be subject to command line -overflows. +response files for this and thus are not subject to command line overflows. -Several tools are participating to the creation of an executable: the compiler +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 an source file that takes care, among other things, of elaboration -issues and global variables initialization; and the linker gathers everything -into a single executable that users can execute. All these tools are known by +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 which switches to be used for any of the tools involved in the build. +express the switches to be used for any of the tools involved in the build. @cindex project file packages A project file is subdivided into zero or more @b{packages}, each of which @@ -617,13 +614,13 @@ packages would be involved in the build process. @noindent Let's first examine the compiler switches. As stated in the initial description -of the example, we want to compile all files with @option{^-O2^-O2^}. This is a +of the example, we want to compile all files with @option{-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^switches^: +Several attributes can be used to specify the switches: @table @asis @item @b{Default_Switches}: @@ -636,22 +633,22 @@ Several attributes can be used to specify the ^switches^switches^: 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^switch^ - @option{^-O2^-O2^}, and the resulting project file is as follows + In this example, we want to compile all Ada source files with the switch + @option{-O2}, and the resulting project file is as follows (only the @code{Compiler} package is shown): @smallexample @b{package} Compiler @b{is} - @b{for} Default_Switches ("Ada") @b{use} ("^-O2^-O2^"); + @b{for} Default_Switches ("Ada") @b{use} ("-O2"); @b{end} Compiler; @end smallexample -@item @b{^Switches^Switches^}: -@cindex @code{^Switches^Switches^} - in some cases, we might want to use specific ^switches^switches^ +@item @b{Switches}: +@cindex @code{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 @emph{^Switches^Switches^} + 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: @@ -659,30 +656,30 @@ Several attributes can be used to specify the ^switches^switches^: @smallexample package Compiler is for Default_Switches ("Ada") - use ("^-O2^-O2^"); - for ^Switches^Switches^ ("proc.adb") - use ("^-O0^-O0^"); + use ("-O2"); + for Switches ("proc.adb") + use ("-O0"); end Compiler; @end smallexample @noindent - @code{^Switches^Switches^} may take a pattern as an index, such as in: + @code{Switches} may take a pattern as an index, such as in: @smallexample package Compiler is for Default_Switches ("Ada") - use ("^-O2^-O2^"); - for ^Switches^Switches^ ("pkg*") - use ("^-O0^-O0^"); + use ("-O2"); + for Switches ("pkg*") + use ("-O0"); end Compiler; @end smallexample @noindent - Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with ^-O0^-O0^, - not ^-O2^-O2^. + Sources @file{pkg.adb} and @file{pkg-child.adb} would be compiled with -O0, + not -O2. @noindent - @code{^Switches^Switches^} can also be given a language name as index instead of a file + @code{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. @@ -696,7 +693,7 @@ Several attributes can be used to specify the ^switches^switches^: @end table The switches for the other tools are defined in a similar manner through the -@b{Default_Switches} and @b{^Switches^Switches^} attributes, respectively in the +@b{Default_Switches} and @b{Switches} attributes, respectively in the @emph{Builder} package (for @command{gnatmake} and @command{gprbuild}), the @emph{Binder} package (binding Ada executables) and the @emph{Linker} package (for linking executables). @@ -711,7 +708,7 @@ Now that our project files are written, let's build our executable. Here is the command we would use from the command line: @smallexample - gnatmake ^-Pbuild^/PROJECT_FILE=build^ + gnatmake -Pbuild @end smallexample @noindent @@ -727,7 +724,7 @@ same way: create the file @file{utils.c} in the @file{common} directory, set the attribute @emph{Languages} to @code{"(Ada, C)"}, and run @smallexample - gprbuild ^-Pbuild^/PROJECT_FILE=build^ + gprbuild -Pbuild @end smallexample @noindent @@ -784,19 +781,19 @@ on Windows), we could configure our project file to build "proc1" (resp proc1.exe) with the following addition: @smallexample @c projectfile - project Build is - ... -- same as before - package Builder is - for Executable ("proc.adb") use "proc1"; - end Builder - end Build; + @b{project} Build @b{is} + ... --@i{ same as before} + @b{package} Builder @b{is} + @b{for} Executable ("proc.adb") @b{use} "proc1"; + @b{end} Builder + @b{end} Build; @end smallexample @noindent @cindex @code{Executable_Suffix} Attribute @b{Executable_Suffix}, when specified, may change the suffix of the executable files, when no attribute @code{Executable} applies: -its value replace the platform-specific executable suffix. +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 @@ -815,18 +812,18 @@ To illustrate some other project capabilities, here is a slightly more complex project using similar sources and a main program in C: @smallexample @c projectfile -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 +@b{project} C_Main @b{is} + @b{for} Languages @b{use} ("Ada", "C"); + @b{for} Source_Dirs @b{use} ("common"); + @b{for} Object_Dir @b{use} "obj"; + @b{for} Main @b{use} ("main.c"); + @b{package} Compiler @b{is} C_Switches := ("-pedantic"); - for Default_Switches ("C") use C_Switches; - for Default_Switches ("Ada") use ("^-gnaty^-gnaty^"); - for ^Switches^Switches^ ("main.c") use C_Switches & ("-g"); - end Compiler; -end C_Main; + @b{for} Default_Switches ("C") @b{use} C_Switches; + @b{for} Default_Switches ("Ada") @b{use} ("-gnaty"); + @b{for} Switches ("main.c") @b{use} C_Switches & ("-g"); + @b{end} Compiler; +@b{end} C_Main; @end smallexample @noindent @@ -848,7 +845,7 @@ In this specific situation the use of a variable could have been replaced by a reference to the @code{Default_Switches} attribute: @smallexample @c projectfile - for ^Switches^Switches^ ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); + @b{for} Switches ("c_main.c") @b{use} Compiler'Default_Switches ("C") & ("-g"); @end smallexample @noindent @@ -940,7 +937,7 @@ The following attributes can be defined in package @code{Naming}: @code{Specification_Exceptions}. If @code{Spec_Suffix ("Ada")} is not specified, then the default is - @code{"^.ads^.ADS^"}. + @code{".ads"}. A non empty value must satisfy the following requirements: @@ -969,7 +966,7 @@ The following attributes can be defined in package @code{Naming}: In addition, they must be different from any of the values in @code{Spec_Suffix}. If @code{Body_Suffix ("Ada")} is not specified, then the default is - @code{"^.adb^.ADB^"}. + @code{".adb"}. If @code{Body_Suffix ("Ada")} and @code{Spec_Suffix ("Ada")} end with the same string, then a file name that ends with the longest of these two @@ -1029,39 +1026,20 @@ The following attributes can be defined in package @code{Naming}: @end table -@ifclear vms +@set unw For example, the following package models the Apex file naming rules: @smallexample @c projectfile @group - 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; + @b{package} Naming @b{is} + @b{for} Casing @b{use} "lowercase"; + @b{for} Dot_Replacement @b{use} "."; + @b{for} Spec_Suffix ("Ada") @b{use} ".1.ada"; + @b{for} Body_Suffix ("Ada") @b{use} ".2.ada"; + @b{end} Naming; @end group @end smallexample -@end ifclear - -@ifset vms -For example, the following package models the DEC Ada file naming rules: -@smallexample @c projectfile -@group - package Naming is - for Casing use "lowercase"; - for Dot_Replacement use "__"; - for Spec_Suffix ("Ada") use "_.ada"; - for Body_Suffix ("Ada") use ".ada"; - end Naming; -@end group -@end smallexample - -@noindent -(Note that @code{Casing} is @code{"lowercase"} because GNAT gets the file -names in lower case) -@end ifset @c --------------------------------------------- @node Installation @@ -1182,29 +1160,29 @@ 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 easily solved by adding the following @b{with} clauses at the beginning -of our project: +This is solved by adding the following @b{with} clauses at the beginning of our +project: @smallexample @c projectfile - with "gtkada.gpr"; - with "a/b/logging.gpr"; - project Build is - ... -- as before - end Build; + @b{with} "gtkada.gpr"; + @b{with} "a/b/logging.gpr"; + @b{project} Build @b{is} + ... --@i{ as before} + @b{end} Build; @end smallexample @noindent @cindex @code{Externally_Built} -When such a project is compiled, @command{gnatmake} will automatically -check the other projects and recompile their sources when needed. It will also +When such a project is compiled, @command{gprbuild} will automatically check +the other projects and recompile their sources when needed. It will also recompile the sources from @code{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, the attribute @b{Externally_Built} to -"true" can be set, 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. +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 @b{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 @code{with} clause has several effects. It provides source visibility between projects during the compilation process. It also guarantees @@ -1219,7 +1197,7 @@ project files rather than packages. Each literal string after @code{with} is the path (absolute or relative) to a project file. The @code{.gpr} extension is optional, although we recommend adding it. If no extension is specified, -and no project file with the @file{^.gpr^.GPR^} extension is found, then +and no project file with the @file{.gpr} extension is found, then the file is searched for exactly as written in the @code{with} clause, that is with no extension. @@ -1233,8 +1211,7 @@ A solution if you need something like this is to use aggregate projects When a relative path or a base name is used, the project files are searched relative to each of the directories in the @b{project path}. This path includes all the directories found with the -following algorithm, in that order, as soon as a matching file is found, -the search stops: +following algorithm, in this order; the first matching file is used: @itemize @bullet @item First, the file is searched relative to the directory that contains the @@ -1245,7 +1222,7 @@ the search stops: @cindex @code{GPR_PROJECT_PATH} @cindex @code{ADA_PROJECT_PATH} Then it is searched relative to all the directories specified in the - ^environment variables^logical names^ @b{GPR_PROJECT_PATH_FILE}, + environment variables @b{GPR_PROJECT_PATH_FILE}, @b{GPR_PROJECT_PATH} and @b{ADA_PROJECT_PATH} (in that order) if they exist. The value of @b{GPR_PROJECT_PATH_FILE}, when defined, is the path name of a text file that contains project directory path names, one per line. @@ -1255,8 +1232,8 @@ the search stops: use @b{GPR_PROJECT_PATH_FILE} or @b{GPR_PROJECT_PATH}. @item Finally, it is searched relative to the default project directories. - Such directories depends on the tool used. The different locations searched - in the specified order are: + Such directories depend on the tool used. The locations searched in the + specified order are: @itemize @bullet @item @file{//lib/gnat} @@ -1371,11 +1348,11 @@ There are two main approaches to avoiding this duplication: @smallexample @c projectfile project Logging is package Compiler is - for ^Switches^Switches^ ("Ada") - use ("^-O2^-O2^"); + for Switches ("Ada") + use ("-O2"); end Compiler; package Binder is - for ^Switches^Switches^ ("Ada") + for Switches ("Ada") use ("-E"); end Binder; end Logging; @@ -1384,7 +1361,7 @@ There are two main approaches to avoiding this duplication: project Build is package Compiler renames Logging.Compiler; package Binder is - for ^Switches^Switches^ ("Ada") use Logging.Binder'Switches ("Ada"); + for Switches ("Ada") use Logging.Binder'Switches ("Ada"); end Binder; end Build; @end smallexample @@ -1407,7 +1384,7 @@ There are two main approaches to avoiding this duplication: @end smallexample @item The second approach is to define the switches in a third project. - That project is setup without any sources (so that, as opposed to + 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}. @@ -1416,8 +1393,8 @@ There are two main approaches to avoiding this duplication: abstract project Shared is for Source_Files use (); -- no sources package Compiler is - for ^Switches^Switches^ ("Ada") - use ("^-O2^-O2^"); + for Switches ("Ada") + use ("-O2"); end Compiler; end Shared; @@ -1499,21 +1476,21 @@ Various aspects of the projects can be modified based on @b{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, when the second will focus on improving code optimization). +information, while the second will focus on improving code optimization). -Let's enhance our example to support a debug and a release modes.The issue is to -let the user choose what kind of system he is building: -use @option{-g} as compiler switches in debug mode and @option{^-O2^-O2^} -in release mode. We will also setup 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 2 modes. +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 @option{-g} as +compiler switches in debug mode and @option{-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 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. +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. @cindex scenarios Instead, project files support the notion of scenarios controlled @@ -1532,27 +1509,27 @@ order of priority): or gnatmake -Pbuild.gpr -Xmode=release @end smallexample -@item @b{^Environment variables^Logical names^}: +@item @b{Environment variables}: When the external value does not come from the command line, it can come from - the value of ^environment variables^logical names^ of the appropriate name. - In our case, if ^an environment variable^a logical name^ called "mode" - exist, its value will be taken into account. + 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. -@item @b{External function second parameter} +@item @b{External function second parameter}. @end table @cindex @code{external} We now need to get that value in the project. The general form is to use the predefined function @b{external} which returns the current value of -the external. For instance, we could setup the object directory to point to +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 @smallexample @c projectfile - project Build is - for Object_Dir use "obj/" & external ("mode", "debug"); - ... -- as before - end Build; + @b{project} Build @b{is} + @b{for} Object_Dir @b{use} "obj/" & @b{external} ("mode", "debug"); + ... --@i{ as before} + @b{end} Build; @end smallexample @noindent @@ -1570,21 +1547,21 @@ Such a variable can then be used in a @b{case construction} and create condition sections in the project. The following example shows how this can be done: @smallexample @c projectfile - 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^Switches^ ("Ada") - use ("-g"); - when "release" => - for ^Switches^Switches^ ("Ada") - use ("^-O2^-O2^"); - end case; - end Compiler; - end Build; + @b{project} Build @b{is} + @b{type} Mode_Type @b{is} ("debug", "release"); --@i{ all possible values} + Mode : Mode_Type := @b{external} ("mode", "debug"); --@i{ a typed variable} + + @b{package} Compiler @b{is} + @b{case} Mode @b{is} + @b{when} "debug" => + @b{for} Switches ("Ada") + @b{use} ("-g"); + @b{when} "release" => + @b{for} Switches ("Ada") + @b{use} ("-O2"); + @b{end} @b{case}; + @b{end} Compiler; + @b{end} Build; @end smallexample @noindent @@ -1599,7 +1576,7 @@ force the user to define the value. Finally, we can use a case construction to s switches depending on the scenario the user has chosen. Most aspects of the projects can depend on scenarios. The notable exception -are project dependencies (@code{with} clauses), which may not depend on a scenario. +are project dependencies (@code{with} clauses), which cannot depend on a scenario. Scenarios work the same way with @b{project hierarchies}: you can either duplicate a variable similar to @code{Mode} in each of the project (as long @@ -1620,7 +1597,7 @@ using system-specific means such as archives or windows DLLs. Library projects provide a system- and language-independent way of building both @b{static} and @b{dynamic} libraries. They also support the concept of @b{standalone -libraries} (SAL) which offers two significant properties: the elaboration +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 @@ -1651,12 +1628,12 @@ installation of the library (i.e., copying associated source, object and @noindent Let's enhance our example and transform the @code{logging} subsystem into a -library. In order to do so, a few changes need to be made to @file{logging.gpr}. -A number of specific attributes needs to be defined: at least @code{Library_Name} -and @code{Library_Dir}; in addition, a number of 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 @code{library} in -front of the @code{project} keyword. +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 +@code{Library_Name} and @code{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 @code{library} +in front of the @code{project} keyword. @table @asis @item @b{Library_Name}: @@ -1664,7 +1641,7 @@ front of the @code{project} keyword. 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. + 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. @@ -1675,7 +1652,7 @@ front of the @code{project} keyword. the sources are compiled, the object files end up in the explicit or implicit @code{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 exists and be + 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. @@ -1684,11 +1661,11 @@ front of the @code{project} keyword. Here is the new version of @file{logging.gpr} that makes it a library: @smallexample @c projectfile -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; +library @b{project} Logging @b{is} --@i{ "library" is optional} + @b{for} Library_Name @b{use} "logging"; --@i{ will create "liblogging.a" on Unix} + @b{for} Object_Dir @b{use} "obj"; + @b{for} Library_Dir @b{use} "lib"; --@i{ different from object_dir} +@b{end} Logging; @end smallexample @noindent @@ -1713,11 +1690,10 @@ Other library-related attributes can be used to change the defaults: a library on different operating systems. If you need to build both a static and a dynamic library, it is recommended - 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 which uses scenarios - to indicate the various kinds of library to be built and their - corresponding object_dir. + 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. @cindex @code{Library_ALI_Dir} @item @b{Library_ALI_Dir}: @@ -1730,7 +1706,7 @@ Other library-related attributes can be used to change the defaults: @cindex @code{Library_Version} @item @b{Library_Version}: - This attribute is platform dependent, and has no effect on VMS and Windows. + 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 @code{"soname"}). If the library file name (built from the @code{Library_Name}) is different from the @code{Library_Version}, @@ -1740,13 +1716,13 @@ Other library-related attributes can be used to change the defaults: @smallexample @c projectfile @group - project Logging is + @b{project} Logging @b{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; + @b{for} Library_Dir @b{use} "lib"; + @b{for} Library_Name @b{use} "logging"; + @b{for} Library_Kind @b{use} "dynamic"; + @b{for} Library_Version @b{use} "liblogging.so." & Version; + @b{end} Logging; @end group @end smallexample @@ -1759,7 +1735,7 @@ Other library-related attributes can be used to change the defaults: @item @b{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 is calling the + accomplishes specific actions before calling gcc (which itself calls the linker to build the library image). @item @b{Library_Options}: @@ -1767,6 +1743,10 @@ Other library-related attributes can be used to change the defaults: 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. + @item @b{Leading_Library_Options}: @cindex @code{Leading_Library_Options} This attribute, that is taken into account only by @command{gprbuild}, may be @@ -1812,11 +1792,10 @@ corresponding to the sources of the project. 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 non 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 +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 @code{Build} only if @file{proc.ads}, @file{pack.ads} or @file{pack.adb} @@ -1824,7 +1803,7 @@ include a @code{"with Log1"}. To ensure that all the sources in the @code{Logging} library are up to date, and that all the sources of @code{Build} are also up to date, -the following two commands needs to be used: +the following two commands need to be used: @smallexample gnatmake -Plogging.gpr @@ -1836,21 +1815,20 @@ All @file{ALI} files will also be copied from the object directory to the library directory. To build executables, @command{gnatmake} will use the library rather than the individual object files. -@ifclear vms -Library projects can also be useful to describe a library that need to be used +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 simply to -use the @code{Externally_Built} attribute as in the example below: +of the library sources are not available. Such library projects need to use the +@code{Externally_Built} attribute as in the example below: @smallexample @c projectfile -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; +library @b{project} Extern_Lib @b{is} + @b{for} Languages @b{use} ("Ada", "C"); + @b{for} Source_Dirs @b{use} ("lib_src"); + @b{for} Library_Dir @b{use} "lib2"; + @b{for} Library_Kind @b{use} "dynamic"; + @b{for} Library_Name @b{use} "l2"; + @b{for} Externally_Built @b{use} "true"; --@i{ <<<<} +@b{end} Extern_Lib; @end smallexample @noindent @@ -1870,7 +1848,6 @@ 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 @code{with} clause, which in turn will trigger the builder to find the proper order of libraries in the final link command. -@end ifclear @c --------------------------------------------- @node Stand-alone Library Projects @@ -1910,9 +1887,9 @@ language and takes a list of sources as parameter. @smallexample @c projectfile @group - for Library_Dir use "lib"; - for Library_Name use "loggin"; - for Library_Interface use ("lib1", "lib2"); -- unit names + @b{for} Library_Dir @b{use} "lib"; + @b{for} Library_Name @b{use} "logging"; + @b{for} Library_Interface @b{use} ("lib1", "lib2"); --@i{ unit names} @end group @end smallexample @@ -1931,7 +1908,7 @@ language and takes a list of sources as parameter. build. Values are either @code{standard} (the default), @code{no} or @code{encapsulated}. When @code{standard} is used the code to elaborate and finalize the library is embedded, when @code{encapsulated} is used the - library can furthermore only depends on static libraries (including + library can furthermore depend only on static libraries (including the GNAT runtime). This attribute can be set to @code{no} to make it clear that the library should not be standalone in which case the @code{Library_Interface} should not defined. Note that this attribute @@ -1940,11 +1917,11 @@ language and takes a list of sources as parameter. @smallexample @c projectfile @group - for Library_Dir use "lib"; - for Library_Name use "loggin"; - for Library_Kind use "dynamic"; - for Library_Interface use ("lib1", "lib2"); -- unit names - for Library_Standalone use "encapsulated"; + @b{for} Library_Dir @b{use} "lib"; + @b{for} Library_Name @b{use} "logging"; + @b{for} Library_Kind @b{use} "dynamic"; + @b{for} Library_Interface @b{use} ("lib1", "lib2"); --@i{ unit names} + @b{for} Library_Standalone @b{use} "encapsulated"; @end group @end smallexample @@ -1952,7 +1929,7 @@ language and takes a list of sources as parameter. 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^B$LOGGING.ADS/B^ in the example). +depends on the library name (b~logging.ads/b in the example). This binder-generated package includes @b{initialization} and @b{finalization} procedures whose names depend on the library name (@code{logginginit} and @code{loggingfinal} in the example). The object corresponding to this package is @@ -1966,7 +1943,7 @@ included in the library. platform and if attribute @b{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 - prevent automatic initialization. + 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 @@ -1992,11 +1969,11 @@ included in the library. 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 @code{Inline} are used, or when there is a generic - units in the spec. This directory cannot point to the object directory or - one of the source directories, but it can point to the library directory, + 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 @code{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. @item @b{Library_Symbol_Policy}: @@ -2066,9 +2043,9 @@ a project file slightly different from the one used to build the library, by using the @code{externally_built} attribute. @ref{Using Library Projects} Another option is to use @command{gprinstall} to install the library in a -different context than the build location. A project to use this library is -generated automatically by @command{gprinstall} which also copy, in the install -location, the minimum set of sources needed to use the library. +different context than the build location. @command{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} @c --------------------------------------------- @@ -2082,7 +2059,7 @@ modified versions of some of the source files, without changing the original sources. This can be achieved through the @b{project extension} facility. Suppose for instance that our example @code{Build} project is built every night -for the whole team, in some shared directory. A developer usually need to work +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 @@ -2092,7 +2069,7 @@ 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 only be used +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 @@ -2113,28 +2090,28 @@ 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 inherits implicitly all the sources and objects from the +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 dirs 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 -@code{Build} from previous examples: +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 @code{Build} from previous examples: @smallexample @c projectfile - project Work extends "../bld/build.gpr" is - end Work; + @b{project} Work @b{extends} "../bld/build.gpr" @b{is} + @b{end} Work; @end smallexample @noindent The project after @b{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 (@pxref{Project Dependencies}). This project does not -specify source or object directories, so the default value for these attribute -will be used that is to say the current directory (where project @code{Work} is -placed). We can already compile that project with +specify source or object directories, so the default values for these +attributes will be used that is to say the current directory (where project +@code{Work} is placed). We can compile that project with @smallexample - gnatmake -Pwork + gprbuild -Pwork @end smallexample @noindent @@ -2144,14 +2121,14 @@ sources it inherited from @code{Build}, therefore all the object files in @code{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 Work's current directory (likely -by copying the one from the @code{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. +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 +@code{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, @command{gnatmake} will now automatically recompile +When we recompile, @command{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. @@ -2200,7 +2177,7 @@ 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: @code{Languages}, @code{Main} (for a root non library project) and -@code{Library_Name} (for a project extending a library project) +@code{Library_Name} (for a project extending a library project). @menu * Project Hierarchy Extension:: @@ -2236,18 +2213,18 @@ create several extending projects: @noindent @smallexample @c projectfile - 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; + @b{project} A_Ext @b{extends} "a.gpr" @b{is} + @b{for} Source_Files @b{use} ("a1.adb", "a1.ads"); + @b{end} A_Ext; + + @b{with} "a_ext.gpr"; + @b{project} B_Ext @b{extends} "b.gpr" @b{is} + @b{end} B_Ext; + + @b{with} "b_ext.gpr"; + @b{project} C_Ext @b{extends} "c.gpr" @b{is} + @b{for} Source_Files @b{use} ("c1.adb"); + @b{end} C_Ext; @end smallexample @noindent @@ -2259,7 +2236,7 @@ import @file{b.gpr} which itself knows nothing about @file{a_ext.gpr}. 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 @b{implicit extension} of entire hierarchy using @b{extends all} +an @b{implicit extension} of an entire hierarchy using @b{extends all} relationship. When the project is extended using @code{extends all} inheritance, all projects @@ -2276,7 +2253,7 @@ 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. +that depend on them are recompiled. Thus, in our example we could create the following projects instead: @@ -2288,14 +2265,14 @@ Thus, in our example we could create the following projects instead: @noindent @smallexample @c projectfile - 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; + @b{project} A_Ext @b{extends} "a.gpr" @b{is} + @b{for} Source_Files @b{use} ("a1.adb", "a1.ads"); + @b{end} A_Ext; + + @b{with} "a_ext.gpr"; + @b{project} C_Ext @b{extends} @b{all} "c.gpr" @b{is} + @b{for} Source_Files @b{use} ("c1.adb"); + @b{end} C_Ext; @end smallexample @noindent @@ -2365,9 +2342,9 @@ and C. Then, when you build with this will build all mains from A, B and C. @smallexample @c projectfile - aggregate project Agg is - for Project_Files use ("a.gpr", "b.gpr", "c.gpr"); - end Agg; + aggregate @b{project} Agg @b{is} + @b{for} Project_Files @b{use} ("a.gpr", "b.gpr", "c.gpr"); + @b{end} Agg; @end smallexample If B or C do not define any main program (through their Main @@ -2380,7 +2357,7 @@ 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. -Aggregate projects are only supported with @command{gprbuild}, but not with +Aggregate projects are supported only with @command{gprbuild}, not with @command{gnatmake}. @c --------------------------------------------------------- @@ -2426,7 +2403,7 @@ The environment variables at the time you launch @command{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" statement,...). Several command line switches +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. @@ -2438,41 +2415,40 @@ make sure all your user have a consistent environment when building. The syntax looks like @smallexample @c projectfile - 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 ^Switches^Switches^ ("Ada") use ("-q"); - end Builder; - end Agg; + aggregate @b{project} Agg @b{is} + @b{for} Project_Files @b{use} ("A.gpr", "B.gpr"); + @b{for} Project_Path @b{use} ("../dir1", "../dir1/dir2"); + @b{for} External ("BUILD") @b{use} "PRODUCTION"; + + @b{package} Builder @b{is} + @b{for} Switches ("Ada") @b{use} ("-q"); + @b{end} Builder; + @b{end} Agg; @end smallexample One of the often requested features in projects is to be able to -reference external variables in @code{with} statements, as in +reference external variables in @code{with} declarations, as in @smallexample @c projectfile - with external("SETUP") & "path/prj.gpr"; -- ILLEGAL - project MyProject is + @b{with} @b{external}("SETUP") & "path/prj.gpr"; --@i{ ILLEGAL} + @b{project} MyProject @b{is} ... - end MyProject; + @b{end} MyProject; @end smallexample -For various reasons, this isn't authorized. But using aggregate -projects provide an elegant solution. For instance, you could -use a project file like: +For various reasons, this is not allowed. But using aggregate projects provide +an elegant solution. For instance, you could use a project file like: @smallexample @c projectfile -aggregate project Agg is - for Project_Path use (external("SETUP") % "path"); - for Project_Files use ("myproject.gpr"); -end Agg; +aggregate @b{project} Agg @b{is} + @b{for} Project_Path @b{use} (@b{external}("SETUP") & "path"); + @b{for} Project_Files @b{use} ("myproject.gpr"); +@b{end} Agg; -with "prj.gpr"; -- searched on Agg'Project_Path -project MyProject is +@b{with} "prj.gpr"; --@i{ searched on Agg'Project_Path} +@b{project} MyProject @b{is} ... -end MyProject; +@b{end} MyProject; @end smallexample @c -------------------------------------------- @@ -2483,7 +2459,7 @@ end MyProject; The loading of aggregate projects is optimized in @command{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 +compilation times, especially on systems with sources on remote servers). As part of the loading, @command{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 @@ -2534,12 +2510,9 @@ attributes and packages are forbidden in an aggregate project. Here is the The only package that is authorized (albeit optional) is Builder. Other packages (in particular Compiler, Binder and Linker) -are forbidden. It is an error to have any of these -(and such an error prevents the proper loading of the aggregate -project). +are forbidden. -Three new attributes have been created, which can only be used in the -context of aggregate projects: +The following three attributes can be used only in an aggregate project: @table @asis @item @b{Project_Files}: @@ -2582,29 +2555,30 @@ number of system calls that are needed. Here are a few valid examples: @smallexample @c projectfile - for Project_Files use ("a.gpr", "subdir/b.gpr"); - -- two specific projects relative to the directory of agg.gpr + @b{for} Project_Files @b{use} ("a.gpr", "subdir/b.gpr"); + --@i{ two specific projects relative to the directory of agg.gpr} - for Project_Files use ("**/*.gpr"); - -- all projects recursively + @b{for} Project_Files @b{use} ("**/*.gpr"); + --@i{ all projects recursively} @end smallexample @item @b{Project_Path}: @cindex @code{Project_Path} This attribute can be used to specify a list of directories in -which to look for project files in @code{with} statements. +which to look for project files in @code{with} declarations. -When you specify a project in Project_Files -say @code{"x/y/a.gpr"}), and this projects imports a project "b.gpr", only -b.gpr is searched in the project path. a.gpr must be exactly at -/x/y/a.gpr. +When you specify a project in Project_Files (say @code{x/y/a.gpr}), and +@code{a.gpr} imports a project @code{b.gpr}, only @code{b.gpr} is searched in +the project path. @code{a.gpr} must be exactly at +@code{/x/y/a.gpr}. This attribute, however, does not affect the search for the aggregated project files specified with @code{Project_Files}. -Each aggregate project has its own (that is if agg1.gpr includes -agg2.gpr, they can potentially both have a different project path). +Each aggregate project has its own @code{Project_Path} (that is if +@code{agg1.gpr} includes @code{agg2.gpr}, they can potentially both have a +different @code{Project_Path}). This project path is defined as the concatenation, in that order, of: @@ -2653,17 +2627,17 @@ this will be reported as an error by the builder. Directories are relative to the location of the aggregate project file. -Here are a few valid examples: +Example: @smallexample @c projectfile - for Project_Path use ("/usr/local/gpr", "gpr/"); + @b{for} Project_Path @b{use} ("/usr/local/gpr", "gpr/"); @end smallexample @item @b{External}: @cindex @code{External} This attribute can be used to set the value of environment -variables as retrieved through the @code{external} statement +variables as retrieved through the @code{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). @@ -2682,7 +2656,7 @@ sources (each level overrides the previous levels): These override the value given by the attribute, so that users can override the value set in the (presumably shared -with others in his team) aggregate project. +with others team members) aggregate project. @item The -X command line switch to @command{gprbuild} @@ -2714,8 +2688,8 @@ an aggregate project. In this package, only the following attributes are valid: @table @asis -@item @b{^Switches^Switches^}: -@cindex @code{^Switches^Switches^} +@item @b{Switches}: +@cindex @code{Switches} This attribute gives the list of switches to use for @command{gprbuild}. Because no mains can be specified for aggregate projects, the only possible index for attribute @code{Switches} is @code{others}. All other indexes will @@ -2724,7 +2698,7 @@ be ignored. Example: @smallexample @c projectfile -for ^Switches^Switches^ (other) use ("-v", "-k", "-j8"); +@b{for} Switches (@b{others}) @b{use} ("-v", "-k", "-j8"); @end smallexample These switches are only read from the main aggregate project (the @@ -2740,8 +2714,8 @@ This attribute gives the list of compiler switches for the various languages. For instance, @smallexample @c projectfile -for Global_Compilation_Switches ("Ada") use ("^O1^-O1^", "-g"); -for Global_Compilation_Switches ("C") use ("^-O2^-O2^"); +@b{for} Global_Compilation_Switches ("Ada") @b{use} ("O1", "-g"); +@b{for} Global_Compilation_Switches ("C") @b{use} ("-O2"); @end smallexample This attribute is only taken into account in the aggregate project @@ -2760,57 +2734,57 @@ instance, aggregate project Agg groups the projects A and B, that both depend on C. Here is an extra for all of these projects: @smallexample @c projectfile - aggregate project Agg is - for Project_Files use ("a.gpr", "b.gpr"); - package Builder is - for Global_Compilation_Switches ("Ada") use ("^-O2^-O2^"); - end Builder; - end Agg; - - with "c.gpr"; - project A is - package Builder is - for Global_Compilation_Switches ("Ada") use ("^-O1^-O1^"); - -- ignored - end Builder; - - package Compiler is - for Default_Switches ("Ada") - use ("^-O1^-O1^", "-g"); - for ^Switches^Switches^ ("a_file1.adb") - use ("^-O0^-O0^"); - end Compiler; - end A; - - with "c.gpr"; - project B is - package Compiler is - for Default_Switches ("Ada") use ("^-O0^-O0^"); - end Compiler; - end B; - - project C is - package Compiler is - for Default_Switches ("Ada") - use ("^-O3^-O3^", - "^-gnatn^-gnatn^"); - for ^Switches^Switches^ ("c_file1.adb") - use ("^-O0^-O0^", "-g"); - end Compiler; - end C; + aggregate @b{project} Agg @b{is} + @b{for} Project_Files @b{use} ("a.gpr", "b.gpr"); + @b{package} Builder @b{is} + @b{for} Global_Compilation_Switches ("Ada") @b{use} ("-O2"); + @b{end} Builder; + @b{end} Agg; + + @b{with} "c.gpr"; + @b{project} A @b{is} + @b{package} Builder @b{is} + @b{for} Global_Compilation_Switches ("Ada") @b{use} ("-O1"); + --@i{ ignored} + @b{end} Builder; + + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-O1", "-g"); + @b{for} Switches ("a_file1.adb") + @b{use} ("-O0"); + @b{end} Compiler; + @b{end} A; + + @b{with} "c.gpr"; + @b{project} B @b{is} + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") @b{use} ("-O0"); + @b{end} Compiler; + @b{end} B; + + @b{project} C @b{is} + @b{package} Compiler @b{is} + @b{for} Default_Switches ("Ada") + @b{use} ("-O3", + "-gnatn"); + @b{for} Switches ("c_file1.adb") + @b{use} ("-O0", "-g"); + @b{end} Compiler; + @b{end} C; @end smallexample then the following switches are used: @itemize @bullet @item all files from project A except a_file1.adb are compiled - with "^-O2^-O2^ -g", since the aggregate project has priority. + with "-O2 -g", since the aggregate project has priority. @item the file a_file1.adb is compiled with - "^-O0^-O0^", since the Compiler.Switches has priority + "-O0", since the Compiler.Switches has priority @item all files from project B are compiled with - "^-O2^-O2^", since the aggregate project has priority -@item all files from C are compiled with "^-O2^-O2^ -gnatn", except for - c_file1.adb which is compiled with "^-O0^-O0^ -g" + "-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 @@ -2871,11 +2845,11 @@ For example, we can define an aggregate project Agg that groups A, B and C: @smallexample @c projectfile - 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; + aggregate library @b{project} Agg @b{is} + @b{for} Project_Files @b{use} ("a.gpr", "b.gpr", "c.gpr"); + @b{for} Library_Name @b{use} ("agg"); + @b{for} Library_Dir @b{use} ("lagg"); + @b{end} Agg; @end smallexample Then, when you build with: @@ -2885,26 +2859,26 @@ Then, when you build with: @end smallexample This will build all units from projects A, B and C and will create a -static library named @file{libagg.a} into the @file{lagg} +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 aggregates a +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: @smallexample @c projectfile - 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; + aggregate library @b{project} Agg @b{is} + @b{for} Project_Files @b{use} ("a.gpr", "b.gpr", "c.gpr"); + @b{for} Library_Name @b{use} ("agg"); + @b{for} Library_Dir @b{use} ("lagg"); + @b{for} Library_Kind @b{use} "relocatable"; + + @b{package} Builder @b{is} + @b{for} Global_Compilation_Switches ("Ada") @b{use} ("-fPIC"); + @b{end} Builder; + @b{end} Agg; @end smallexample With the above aggregate library Builder package, the @code{-fPIC} @@ -2987,8 +2961,8 @@ Project files have an Ada-like syntax. The minimal project file is: @smallexample @c projectfile @group -project Empty is -end Empty; +@b{project} Empty @b{is} +@b{end} Empty; @end group @end smallexample @@ -3042,7 +3016,7 @@ 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 variable ADA_PROJECT_PATH and +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. @@ -3050,27 +3024,26 @@ 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 clause +dependency graph cannot contain cycles), except when one of the with clauses in the cycle is a @b{limited with}. @c ??? Need more details here @smallexample @c projectfile -with "other_project.gpr"; -project My_Project extends "extended.gpr" is -end My_Project; +@b{with} "other_project.gpr"; +@b{project} My_Project @b{extends} "extended.gpr" @b{is} +@b{end} My_Project; @end smallexample @noindent These dependencies form a @b{directed graph}, potentially cyclic when using -@b{limited with}. The subprogram reflecting the @b{extends} relations is a -tree. +@b{limited with}. The subgraph reflecting the @b{extends} relations is a tree. A project's @b{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 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. +More generally, a project's @b{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 @b{project hierarchy} can be created, where projects are children of other projects. The name of such a child project must be @code{Parent.Child}, @@ -3192,28 +3165,28 @@ The following packages are currently supported in project files @item Cross_Reference This package specifies the options used when calling the library tool @command{gnatxref} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. @ifclear FSFEDITION @item Eliminate This package specifies the options used when calling the tool @command{gnatelim} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. @end ifclear @item Finder This package specifies the options used when calling the search tool @command{gnatfind} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. -@item ^Gnatls^Gnatls^ +@item Gnatls This package specifies the options to use when invoking @command{gnatls} via the @command{gnat} driver. @ifclear FSFEDITION -@item ^Gnatstub^Gnatstub^ +@item Gnatstub This package specifies the options used when calling the tool @command{gnatstub} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. @end ifclear @item IDE @@ -3229,7 +3202,7 @@ The following packages are currently supported in project files @item Metrics This package specifies the options used when calling the tool @command{gnatmetric} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. @end ifclear @item Naming @@ -3242,7 +3215,7 @@ The following packages are currently supported in project files @item Pretty_Printer This package specifies the options used when calling the formatting tool @command{gnatpp} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. @end ifclear @item Remote @@ -3251,7 +3224,7 @@ The following packages are currently supported in project files @item Stack This package specifies the options used when calling the tool @command{gnatstack} via the @command{gnat} driver. Its attributes - @b{Default_Switches} and @b{^Switches^Switches^} have the same semantics as for the + @b{Default_Switches} and @b{Switches} have the same semantics as for the package @code{Builder}. @item Synchronize This package specifies the options used when calling the tool @@ -3263,10 +3236,10 @@ In its simplest form, a package may be empty: @smallexample @c projectfile @group -project Simple is - package Builder is - end Builder; -end Simple; +@b{project} Simple @b{is} + @b{package} Builder @b{is} + @b{end} Builder; +@b{end} Simple; @end group @end smallexample @@ -3372,9 +3345,9 @@ strings is involved, the result of the concatenation is a list of strings. The following Ada declarations show the existing operators: @smallexample @c 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; + @b{function} "&" (X : String; Y : String) @b{return} String; + @b{function} "&" (X : String_List; Y : String) @b{return} String_List; + @b{function} "&" (X : String_List; Y : String_List) @b{return} String_List; @end smallexample @noindent @@ -3382,10 +3355,10 @@ Here are some specific examples: @smallexample @c projectfile @group - 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 + List := () & File_Name; --@i{ One string in this list} + List2 := List & (File_Name & ".orig"); --@i{ Two strings} + Big_List := List & Lists2; --@i{ Three strings} + Illegal := "gnat.adc" & List2; --@i{ Illegal, must start with list} @end group @end smallexample @@ -3415,9 +3388,9 @@ 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^logical name^ +environment variables or be specified on the command line through the -@option{^-X^/EXTERNAL_REFERENCE=^@emph{vbl}=@emph{value}} switch. If both +@option{-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. @@ -3430,7 +3403,7 @@ 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 @b{case} statements to control the value assigned to +are then used in @b{case} constructions to control the value assigned to attributes in various scenarios. Thus such variables are often called @b{scenario variables}. @@ -3460,14 +3433,14 @@ last separator and the end are components of the string list. @end smallexample @noindent -If the external value is "^-O2^-O2^,-g", -the result is ("^-O2^-O2^", "-g"). +If the external value is "-O2,-g", +the result is ("-O2", "-g"). -If the external value is ",^-O2^-O2^,-g,", -the result is also ("^-O2^-O2^", "-g"). +If the external value is ",-O2,-g,", +the result is also ("-O2", "-g"). -if the external value is "^-gnatv^-gnatv^", -the result is ("^-gnatv^-gnatv^"). +if the external value is "-gnatv", +the result is ("-gnatv"). If the external value is ",,", the result is (""). @@ -3496,7 +3469,7 @@ They may include any graphic characters allowed in Ada, including spaces. Here is an example of a string type declaration: @smallexample @c projectfile - type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS"); + @b{type} OS @b{is} ("NT", "nt", "Unix", "GNU/Linux", "other OS"); @end smallexample @noindent @@ -3551,8 +3524,8 @@ Here are some examples of variable declarations: @smallexample @c projectfile @group - This_OS : OS := external ("OS"); -- a typed variable declaration - That_OS := "GNU/Linux"; -- an untyped variable declaration + This_OS : OS := @b{external} ("OS"); --@i{ a typed variable declaration} + That_OS := "GNU/Linux"; --@i{ an untyped variable declaration} Name := "readme.txt"; Save_Name := Name & ".saved"; @@ -3592,8 +3565,8 @@ A @b{context} may be one of the following: @c --------------------------------------------- @noindent -A @b{case} statement is used in a project file to effect conditional -behavior. Through this statement, you can set the value of attributes +A @b{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. @@ -3601,30 +3574,30 @@ 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 @code{others} choice must appear last in the list of alternatives. -The syntax of a @code{case} construction is based on the Ada case statement -(although the @code{null} statement for empty alternatives is optional). +The syntax of a @code{case} construction is based on the Ada case construction +(although the @code{null} declaration for empty alternatives is optional). -The case expression must be a typed string variable, whose value is often -given by an external reference (@pxref{External Values}). +The case expression must be a string variable, either typed or not, whose value +is often given by an external reference (@pxref{External Values}). Each alternative starts with the reserved word @code{when}, either a list of literal strings separated by the @code{"|"} character or the reserved word @code{others}, and the @code{"=>"} token. -Each literal string must belong to the string type that is the type of the -case variable. -After each @code{=>}, there are zero or more statements. The only -statements allowed in a case construction are other case constructions, +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 @code{=>}, 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. @smallexample -case_statement ::= - @i{case} @i{}name @i{is} @{case_item@} @i{end case} ; +case_construction ::= + @i{case} @i{}name @i{is} @{case_item@} @i{end case} ; case_item ::= @i{when} discrete_choice_list => - @{case_statement + @{case_declaration | attribute_declaration | variable_declaration | empty_declaration@} @@ -3633,27 +3606,27 @@ discrete_choice_list ::= string_literal @{| string_literal@} | @i{others} @end smallexample @noindent -Here is a typical example: +Here is a typical example, with a typed string variable: @smallexample @c projectfile @group -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^Switches^ ("Ada") - use ("-gnath"); - when "NT" => - for ^Switches^Switches^ ("Ada") - use ("^-gnatP^-gnatP^"); - when others => - null; - end case; - end Compiler; -end MyProj; +@b{project} MyProj @b{is} + @b{type} OS_Type @b{is} ("GNU/Linux", "Unix", "NT", "VMS"); + OS : OS_Type := @b{external} ("OS", "GNU/Linux"); + + @b{package} Compiler @b{is} + @b{case} OS @b{is} + @b{when} "GNU/Linux" | "Unix" => + @b{for} Switches ("Ada") + @b{use} ("-gnath"); + @b{when} "NT" => + @b{for} Switches ("Ada") + @b{use} ("-gnatP"); + @b{when} @b{others} => + @b{null}; + @b{end} @b{case}; + @b{end} Compiler; +@b{end} MyProj; @end group @end smallexample @@ -3676,9 +3649,9 @@ end MyProj; * Package Eliminate Attributes:: @end ifclear * Package Finder Attributes:: -* Package ^gnatls^gnatls^ Attributes:: +* Package gnatls Attributes:: @ifclear FSFEDITION -* Package ^gnatstub^gnatstub^ Attributes:: +* Package gnatstub Attributes:: @end ifclear * Package IDE Attributes:: * Package Install Attributes:: @@ -3731,30 +3704,31 @@ attribute, and replaces the previous setting. Here are some examples of attribute declarations: @smallexample @c projectfile - -- simple attributes - for Object_Dir use "objects"; - for Source_Dirs use ("units", "test/drivers"); - - -- indexed attributes - for Body ("main") use "Main.ada"; - for ^Switches^Switches^ ("main.ada") - use ("-v", "^-gnatv^-gnatv^"); - for ^Switches^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; + --@i{ simple attributes} + @b{for} Object_Dir @b{use} "objects"; + @b{for} Source_Dirs @b{use} ("units", "test/drivers"); + + --@i{ indexed attributes} + @b{for} Body ("main") @b{use} "Main.ada"; + @b{for} Switches ("main.ada") + @b{use} ("-v", "-gnatv"); + @b{for} Switches ("main.ada") @b{use} Builder'Switches ("main.ada") & "-g"; + + --@i{ indexed attributes copy (from package Builder in project Default)} + --@i{ The package name must always be specified, even if it is the current} + --@i{ package.} + @b{for} Default_Switches @b{use} Default.Builder'Default_Switches; @end smallexample @noindent 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. +empty string or the empty list, with some exceptions. @smallexample -attribute_reference ::= attribute_prefix ' @i{_}simple_name [ (string_literal) ] +attribute_reference ::= + attribute_prefix ' @i{_}simple_name [ (string_literal) ] attribute_prefix ::= @i{project} | @i{}simple_name | package_identifier @@ -3765,13 +3739,22 @@ attribute_prefix ::= @i{project} Examples are: @smallexample @c projectfile - project'Object_Dir + @b{project}'Object_Dir Naming'Dot_Replacement Imported_Project'Source_Dirs Imported_Project.Naming'Casing Builder'Default_Switches ("Ada") @end smallexample +The exceptions to the empty defaults are: + +@itemize @bullet +@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 + @noindent The prefix of an attribute may be: @@ -3791,8 +3774,8 @@ 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 create dynamically new packages with -attributes, or new attribute in predefined packages. These attributes are +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 @@ -4100,9 +4083,9 @@ directory in the run path options. @item @b{Separate_Run_Path_Options}: single -Indicates if there may be or not several run path options specified when -linking an executable. Only authorized case-insensitive b=values are "true" or -"false" (the default). +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 @b{Toolchain_Version}: single, indexed, case-insensitive index @@ -4244,9 +4227,9 @@ sources of runtime libraries are located. @item @b{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^. +code of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, +@item @b{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 @@ -4301,7 +4284,7 @@ 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 @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4348,9 +4331,9 @@ project tree. Index is a language name. Value is a list of switches to be used when invoking @code{gnatcheck} for a source of the language, if there is no applicable -attribute ^Switches^Switches^. +attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4364,7 +4347,7 @@ invoking @code{gnatcheck} for the source. @itemize @bullet -@item @b{^Switches^Switches^}: list +@item @b{Switches}: list Value is a list of switches to be used by the cleaning application. @@ -4407,7 +4390,7 @@ 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 @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4641,7 +4624,7 @@ Index is a language name. Value is a list of switches to be used when invoking @code{gnatxref} for a source of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4661,7 +4644,7 @@ Index is a language name. Value is a list of switches to be used when invoking @code{gnatelim} for a source of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4681,7 +4664,7 @@ Index is a language name. Value is a list of switches to be used when invoking @code{gnatfind} for a source of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4689,20 +4672,20 @@ invoking @code{gnatfind} for the source. @end itemize -@node Package ^gnatls^gnatls^ Attributes -@subsubsection Package ^gnatls^gnatls^ Attributes +@node Package gnatls Attributes +@subsubsection Package gnatls Attributes @itemize @bullet -@item @b{^Switches^Switches^}: list +@item @b{Switches}: list Value is a list of switches to be used when invoking @code{gnatls}. @end itemize @ifclear FSFEDITION -@node Package ^gnatstub^gnatstub^ Attributes -@subsubsection Package ^gnatstub^gnatstub^ Attributes +@node Package gnatstub Attributes +@subsubsection Package gnatstub Attributes @itemize @bullet @@ -4710,9 +4693,9 @@ Value is a list of switches to be used when invoking @code{gnatls}. Index is a language name. Value is a list of switches to be used when invoking @code{gnatstub} for a source of the language, if there is no applicable -attribute ^Switches^Switches^. +attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4760,11 +4743,11 @@ the handling of switches. 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 @b{^gnatlist^gnatlist^}: single +@item @b{gnatlist}: single -Value is a string that specifies the name of the @command{^gnatls^gnatls^} utility +Value is a string that specifies the name of the @command{gnatls} utility to be used to retrieve information about the predefined path; for example, -@code{"^gnatls^gnatls^"}, @code{"powerpc-wrs-vxworks-gnatls"}. +@code{"gnatls"}, @code{"powerpc-wrs-vxworks-gnatls"}. @item @b{VCS_Kind}: single @@ -4850,7 +4833,7 @@ 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 @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -4924,7 +4907,7 @@ Index is a language name. Value is a list of switches to be used when invoking @code{gnatmetric} for a source of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -5014,7 +4997,7 @@ Index is a language name. Value is a list of switches to be used when invoking @code{gnatpp} for a source of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @@ -5059,7 +5042,7 @@ Value is the root directory used by the slave machines. @itemize @bullet -@item @b{^Switches^Switches^}: list +@item @b{Switches}: list Value is the list of switches to be used when invoking @code{gnatstack}. @@ -5076,11 +5059,10 @@ Index is a language name. Value is a list of switches to be used when invoking @code{gnatsync} for a source of the language, if there is no applicable attribute Switches. -@item @b{^Switches^Switches^}: list, optional index, indexed, case-insensitive index, +@item @b{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 @code{gnatsync} for the source. @end itemize - diff --git a/main/gcc/ada/repinfo.adb b/main/gcc/ada/repinfo.adb index 5d1c1db6172..cd76da56959 100644 --- a/main/gcc/ada/repinfo.adb +++ b/main/gcc/ada/repinfo.adb @@ -166,7 +166,8 @@ package body Repinfo is procedure List_Scalar_Storage_Order (Ent : Entity_Id; Bytes_Big_Endian : Boolean); - -- List scalar storage order information for record or array type Ent + -- List scalar storage order information for record or array type Ent. + -- Also includes bit order information for record types, if necessary. procedure List_Type_Info (Ent : Entity_Id); -- List type info for type Ent @@ -1067,20 +1068,22 @@ package body Repinfo is (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is - procedure List_Attr (Attr_Name : String); - -- Show attribute definition clause for Attr_Name + procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean); + -- Show attribute definition clause for Attr_Name (an endianness + -- attribute), depending on whether or not the endianness is reversed + -- compared to native endianness. --------------- -- List_Attr -- --------------- - procedure List_Attr (Attr_Name : String) is + procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is begin Write_Str ("for "); List_Name (Ent); Write_Str ("'" & Attr_Name & " use System."); - if Bytes_Big_Endian xor Reverse_Storage_Order (Ent) then + if Bytes_Big_Endian xor Is_Reversed then Write_Str ("High"); else Write_Str ("Low"); @@ -1089,19 +1092,32 @@ package body Repinfo is Write_Line ("_Order_First;"); end List_Attr; + List_SSO : constant Boolean := + Has_Rep_Item (Ent, Name_Scalar_Storage_Order) + or else SSO_Set_Low_By_Default (Ent) + or else SSO_Set_High_By_Default (Ent); + -- Scalar_Storage_Order is displayed if specified explicitly + -- or set by Default_Scalar_Storage_Order. + -- Start of processing for List_Scalar_Storage_Order begin - if Has_Rep_Item (Ent, Name_Scalar_Storage_Order) then + -- For record types, list Bit_Order if not default, or if SSO is shown - -- For a record type with explicitly specified scalar storage order, - -- also display explicit Bit_Order. + if Is_Record_Type (Ent) + and then (List_SSO or else Reverse_Bit_Order (Ent)) + then + List_Attr ("Bit_Order", Reverse_Bit_Order (Ent)); + end if; - if Is_Record_Type (Ent) then - List_Attr ("Bit_Order"); - end if; + -- List SSO if required. If not, then storage is supposed to be in + -- native order. - List_Attr ("Scalar_Storage_Order"); + if List_SSO then + List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent)); + else + pragma Assert (not Reverse_Storage_Order (Ent)); + null; end if; end List_Scalar_Storage_Order; @@ -1473,30 +1489,6 @@ package body Repinfo is when -2 => Write_Str ("reference"); - when -3 => - Write_Str ("descriptor"); - - when -4 => - Write_Str ("descriptor (UBS)"); - - when -5 => - Write_Str ("descriptor (UBSB)"); - - when -6 => - Write_Str ("descriptor (UBA)"); - - when -7 => - Write_Str ("descriptor (S)"); - - when -8 => - Write_Str ("descriptor (SB)"); - - when -9 => - Write_Str ("descriptor (A)"); - - when -10 => - Write_Str ("descriptor (NCA)"); - when others => raise Program_Error; end case; diff --git a/main/gcc/ada/restrict.adb b/main/gcc/ada/restrict.adb index 8983f78ee1c..f2e6a1f9e5e 100644 --- a/main/gcc/ada/restrict.adb +++ b/main/gcc/ada/restrict.adb @@ -427,6 +427,7 @@ package body Restrict is if VV < 0 then Info.Unknown (R) := True; Info.Count (R) := 1; + else Info.Count (R) := VV; end if; @@ -442,10 +443,11 @@ package body Restrict is if VV < 0 then Info.Unknown (R) := True; - -- If checked by maximization, do maximization + -- If checked by maximization, nothing to do because the + -- check is per-object. elsif R in Checked_Max_Parameter_Restrictions then - Info.Count (R) := Integer'Max (Info.Count (R), VV); + null; -- If checked by adding, do add, checking for overflow @@ -489,7 +491,7 @@ package body Restrict is -- No_Dispatch restriction is not set. if R = No_Dispatch then - Check_SPARK_Restriction ("class-wide is not allowed", N); + Check_SPARK_05_Restriction ("class-wide is not allowed", N); end if; if UI_Is_In_Int_Range (V) then @@ -554,6 +556,14 @@ package body Restrict is Msg_Issued := True; Restriction_Msg (R, N); end if; + + -- For Max_Entries and the like, do not carry forward the violation + -- count because it does not affect later declarations. + + if R in Checked_Max_Parameter_Restrictions then + Restrictions.Count (R) := 0; + Restrictions.Violated (R) := False; + end if; end Check_Restriction; ------------------------------------- @@ -858,8 +868,8 @@ package body Restrict is -- Process_Restriction_Synonyms -- ---------------------------------- - -- Note: body of this function must be coordinated with list of - -- renaming declarations in System.Rident. + -- 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 @@ -1408,11 +1418,11 @@ package body Restrict is end if; end Set_Restriction_No_Use_Of_Pragma; - ----------------------------- - -- Check_SPARK_Restriction -- - ----------------------------- + -------------------------------- + -- Check_SPARK_05_Restriction -- + -------------------------------- - procedure Check_SPARK_Restriction + procedure Check_SPARK_05_Restriction (Msg : String; N : Node_Id; Force : Boolean := False) @@ -1461,9 +1471,9 @@ package body Restrict is Error_Msg_F ("\\| " & Msg, N); end if; end if; - end Check_SPARK_Restriction; + end Check_SPARK_05_Restriction; - procedure Check_SPARK_Restriction (Msg1, Msg2 : String; N : Node_Id) is + procedure Check_SPARK_05_Restriction (Msg1, Msg2 : String; N : Node_Id) is Msg_Issued : Boolean; Save_Error_Msg_Sloc : Source_Ptr; @@ -1490,7 +1500,7 @@ package body Restrict is Error_Msg_F (Msg2, N); end if; end if; - end Check_SPARK_Restriction; + end Check_SPARK_05_Restriction; ---------------------------------- -- Suppress_Restriction_Message -- diff --git a/main/gcc/ada/restrict.ads b/main/gcc/ada/restrict.ads index 5cae0d6bd58..b16e674b9d2 100644 --- a/main/gcc/ada/restrict.ads +++ b/main/gcc/ada/restrict.ads @@ -258,7 +258,7 @@ package Restrict is -- elaboration routine. If elaboration code is not allowed, an error -- message is posted on the node given as argument. - procedure Check_SPARK_Restriction + procedure Check_SPARK_05_Restriction (Msg : String; N : Node_Id; Force : Boolean := False); @@ -267,9 +267,9 @@ 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_Restriction (Msg1, Msg2 : String; N : Node_Id); - -- Same as Check_SPARK_Restriction except there is a continuation message - -- Msg2 following the initial message Msg1. + procedure Check_SPARK_05_Restriction (Msg1, Msg2 : String; N : Node_Id); + -- Same as Check_SPARK_05_Restriction except there is a continuation + -- message Msg2 following the initial message Msg1. procedure Check_No_Implicit_Aliasing (Obj : Node_Id); -- Obj is a node for which Is_Aliased_View is True, which is being used in @@ -336,7 +336,6 @@ package Restrict is -- Id is a node whose Chars field contains the name of a restriction. -- If it is one of synonyms that we allow for historical purposes (for -- list see System.Rident), then the proper official name is returned. - -- Otherwise the Chars field of the argument is returned unchanged. function Restriction_Active (R : All_Restrictions) return Boolean; pragma Inline (Restriction_Active); diff --git a/main/gcc/ada/rtsfind.adb b/main/gcc/ada/rtsfind.adb index 499b167bb0a..a31215f960b 100644 --- a/main/gcc/ada/rtsfind.adb +++ b/main/gcc/ada/rtsfind.adb @@ -1126,10 +1126,10 @@ package body Rtsfind is procedure Check_RPC; -- Reject programs that make use of distribution features not supported - -- on the current target. Also check that the PCS is compatible with - -- the code generator version. On such targets (VMS, Vxworks, others?) - -- we provide a minimal body for System.Rpc that only supplies an - -- implementation of Partition_Id. + -- on the current target. Also check that the PCS is compatible with the + -- code generator version. On such targets (Vxworks, others?) we provide + -- a minimal body for System.Rpc that only supplies an implementation of + -- Partition_Id. function Find_Local_Entity (E : RE_Id) return Entity_Id; -- This function is used when entity E is in this compilation's main diff --git a/main/gcc/ada/rtsfind.ads b/main/gcc/ada/rtsfind.ads index 72bbd025db8..f1a40821dd8 100644 --- a/main/gcc/ada/rtsfind.ads +++ b/main/gcc/ada/rtsfind.ads @@ -71,7 +71,8 @@ package Rtsfind is -- of Ada.Wide_Wide_Text_IO. -- Names of the form Interfaces_xxx are first level children of - -- Interfaces_CPP refers to package Interfaces.CPP + -- Interfaces. For example, the name Interfaces_Packed_Decimal refers to + -- package Interfaces.Packed_Decimal. -- Names of the form System_xxx are first level children of System, whose -- name is System.xxx. For example, the name System_Str_Concat refers to @@ -202,7 +203,6 @@ package Rtsfind is -- Children of Interfaces - Interfaces_CPP, Interfaces_Packed_Decimal, -- Package System @@ -374,9 +374,7 @@ package Rtsfind is System_Val_Real, System_Val_Uns, System_Val_WChar, - System_Vax_Float_Operations, System_Version_Control, - System_VMS_Exception_Table, System_WCh_StW, System_WCh_WtS, System_Wid_Bool, @@ -466,7 +464,7 @@ package Rtsfind is Ada_Wide_Wide_Text_IO_Modular_IO; subtype Interfaces_Child is RTU_Id - range Interfaces_CPP .. Interfaces_Packed_Decimal; + range Interfaces_Packed_Decimal .. Interfaces_Packed_Decimal; -- Range of values for children of Interfaces subtype System_Child is RTU_Id @@ -1637,61 +1635,9 @@ package Rtsfind is RE_Value_Wide_Character, -- System.Val_WChar RE_Value_Wide_Wide_Character, -- System.Val_WChar - RE_D, -- System.Vax_Float_Operations - RE_F, -- System.Vax_Float_Operations - RE_G, -- System.Vax_Float_Operations - RE_Q, -- System.Vax_Float_Operations - RE_S, -- System.Vax_Float_Operations - RE_T, -- System.Vax_Float_Operations - - RE_D_To_G, -- System.Vax_Float_Operations - RE_F_To_G, -- System.Vax_Float_Operations - RE_F_To_Q, -- System.Vax_Float_Operations - RE_F_To_S, -- System.Vax_Float_Operations - RE_G_To_D, -- System.Vax_Float_Operations - RE_G_To_F, -- System.Vax_Float_Operations - RE_G_To_Q, -- System.Vax_Float_Operations - RE_G_To_T, -- System.Vax_Float_Operations - RE_Q_To_F, -- System.Vax_Float_Operations - RE_Q_To_G, -- System.Vax_Float_Operations - RE_S_To_F, -- System.Vax_Float_Operations - RE_T_To_D, -- System.Vax_Float_Operations - RE_T_To_G, -- System.Vax_Float_Operations - - RE_Abs_F, -- System.Vax_Float_Operations - RE_Abs_G, -- System.Vax_Float_Operations - RE_Add_F, -- System.Vax_Float_Operations - RE_Add_G, -- System.Vax_Float_Operations - RE_Div_F, -- System.Vax_Float_Operations - RE_Div_G, -- System.Vax_Float_Operations - RE_Mul_F, -- System.Vax_Float_Operations - RE_Mul_G, -- System.Vax_Float_Operations - RE_Neg_F, -- System.Vax_Float_Operations - RE_Neg_G, -- System.Vax_Float_Operations - RE_Return_D, -- System.Vax_Float_Operations - RE_Return_F, -- System.Vax_Float_Operations - RE_Return_G, -- System.Vax_Float_Operations - RE_Sub_F, -- System.Vax_Float_Operations - RE_Sub_G, -- System.Vax_Float_Operations - - RE_Eq_F, -- System.Vax_Float_Operations - RE_Eq_G, -- System.Vax_Float_Operations - RE_Le_F, -- System.Vax_Float_Operations - RE_Le_G, -- System.Vax_Float_Operations - RE_Lt_F, -- System.Vax_Float_Operations - RE_Lt_G, -- System.Vax_Float_Operations - RE_Ne_F, -- System.Vax_Float_Operations - RE_Ne_G, -- System.Vax_Float_Operations - - RE_Valid_D, -- System.Vax_Float_Operations - RE_Valid_F, -- System.Vax_Float_Operations - RE_Valid_G, -- System.Vax_Float_Operations - RE_Version_String, -- System.Version_Control RE_Get_Version_String, -- System.Version_Control - RE_Register_VMS_Exception, -- System.VMS_Exception_Table - RE_String_To_Wide_String, -- System.WCh_StW RE_String_To_Wide_Wide_String, -- System.WCh_StW @@ -2924,61 +2870,9 @@ package Rtsfind is RE_Value_Wide_Character => System_Val_WChar, RE_Value_Wide_Wide_Character => System_Val_WChar, - RE_D => System_Vax_Float_Operations, - RE_F => System_Vax_Float_Operations, - RE_G => System_Vax_Float_Operations, - RE_Q => System_Vax_Float_Operations, - RE_S => System_Vax_Float_Operations, - RE_T => System_Vax_Float_Operations, - - RE_D_To_G => System_Vax_Float_Operations, - RE_F_To_G => System_Vax_Float_Operations, - RE_F_To_Q => System_Vax_Float_Operations, - RE_F_To_S => System_Vax_Float_Operations, - RE_G_To_D => System_Vax_Float_Operations, - RE_G_To_F => System_Vax_Float_Operations, - RE_G_To_Q => System_Vax_Float_Operations, - RE_G_To_T => System_Vax_Float_Operations, - RE_Q_To_F => System_Vax_Float_Operations, - RE_Q_To_G => System_Vax_Float_Operations, - RE_S_To_F => System_Vax_Float_Operations, - RE_T_To_D => System_Vax_Float_Operations, - RE_T_To_G => System_Vax_Float_Operations, - - RE_Abs_F => System_Vax_Float_Operations, - RE_Abs_G => System_Vax_Float_Operations, - RE_Add_F => System_Vax_Float_Operations, - RE_Add_G => System_Vax_Float_Operations, - RE_Div_F => System_Vax_Float_Operations, - RE_Div_G => System_Vax_Float_Operations, - RE_Mul_F => System_Vax_Float_Operations, - RE_Mul_G => System_Vax_Float_Operations, - RE_Neg_F => System_Vax_Float_Operations, - RE_Neg_G => System_Vax_Float_Operations, - RE_Return_D => System_Vax_Float_Operations, - RE_Return_F => System_Vax_Float_Operations, - RE_Return_G => System_Vax_Float_Operations, - RE_Sub_F => System_Vax_Float_Operations, - RE_Sub_G => System_Vax_Float_Operations, - - RE_Eq_F => System_Vax_Float_Operations, - RE_Eq_G => System_Vax_Float_Operations, - RE_Le_F => System_Vax_Float_Operations, - RE_Le_G => System_Vax_Float_Operations, - RE_Lt_F => System_Vax_Float_Operations, - RE_Lt_G => System_Vax_Float_Operations, - RE_Ne_F => System_Vax_Float_Operations, - RE_Ne_G => System_Vax_Float_Operations, - - RE_Valid_D => System_Vax_Float_Operations, - RE_Valid_F => System_Vax_Float_Operations, - RE_Valid_G => System_Vax_Float_Operations, - RE_Version_String => System_Version_Control, RE_Get_Version_String => System_Version_Control, - RE_Register_VMS_Exception => System_VMS_Exception_Table, - RE_String_To_Wide_String => System_WCh_StW, RE_String_To_Wide_Wide_String => System_WCh_StW, diff --git a/main/gcc/ada/s-arit64.adb b/main/gcc/ada/s-arit64.adb index 51b05f9a235..adcb66fb9f1 100644 --- a/main/gcc/ada/s-arit64.adb +++ b/main/gcc/ada/s-arit64.adb @@ -259,8 +259,8 @@ package body System.Arith_64 is T2 := 0; end if; - -- Here we have T2 set to the contribution to the upper half - -- of the result from the upper halves of the input values. + -- Here we have T2 set to the contribution to the upper half of the + -- result from the upper halves of the input values. T1 := Xlo * Ylo; T2 := T2 + Hi (T1); @@ -332,9 +332,9 @@ package body System.Arith_64 is Scale : Natural; -- Scaling factor used for multiple-precision divide. Dividend and - -- Divisor are multiplied by 2 ** Scale, and the final remainder - -- is divided by the scaling factor. The reason for this scaling - -- is to allow more accurate estimation of quotient digits. + -- Divisor are multiplied by 2 ** Scale, and the final remainder is + -- divided by the scaling factor. The reason for this scaling is to + -- allow more accurate estimation of quotient digits. T1, T2, T3 : Uns64; -- Temporary values @@ -383,8 +383,8 @@ package body System.Arith_64 is D (1) := 0; end if; - -- Now it is time for the dreaded multiple precision division. First - -- an easy case, check for the simple case of a one digit divisor. + -- Now it is time for the dreaded multiple precision division. First an + -- easy case, check for the simple case of a one digit divisor. if Zhi = 0 then if D (1) /= 0 or else D (2) >= Zlo then diff --git a/main/gcc/ada/s-assert.adb b/main/gcc/ada/s-assert.adb index 92bb96f09cf..3828cc13b2b 100644 --- a/main/gcc/ada/s-assert.adb +++ b/main/gcc/ada/s-assert.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-asthan-vms-alpha.adb b/main/gcc/ada/s-asthan-vms-alpha.adb deleted file mode 100644 index 253870f619b..00000000000 --- a/main/gcc/ada/s-asthan-vms-alpha.adb +++ /dev/null @@ -1,603 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS/Alpha version - -with System; use System; - -with System.IO; - -with System.Machine_Code; -with System.Parameters; -with System.Storage_Elements; - -with System.Tasking; -with System.Tasking.Rendezvous; -with System.Tasking.Initialization; -with System.Tasking.Utilities; - -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - -with Ada.Finalization; -with Ada.Task_Attributes; - -with Ada.Exceptions; use Ada.Exceptions; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body System.AST_Handling is - - package ATID renames Ada.Task_Identification; - - package SP renames System.Parameters; - package ST renames System.Tasking; - package STR renames System.Tasking.Rendezvous; - package STI renames System.Tasking.Initialization; - package STU renames System.Tasking.Utilities; - - package SSE renames System.Storage_Elements; - package STPO renames System.Task_Primitives.Operations; - package STPOD renames System.Task_Primitives.Operations.DEC; - - AST_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion - -- from all other AST tasks. It is only used by Lock_AST and - -- Unlock_AST. - - procedure Lock_AST (Self_ID : ST.Task_Id); - -- Locks out other AST tasks. Preceding a section of code by Lock_AST and - -- following it by Unlock_AST creates a critical region. - - procedure Unlock_AST (Self_ID : ST.Task_Id); - -- Releases lock previously set by call to Lock_AST. - -- All nested locks must be released before other tasks competing for the - -- tasking lock are released. - - -------------- - -- Lock_AST -- - -------------- - - procedure Lock_AST (Self_ID : ST.Task_Id) is - begin - STI.Defer_Abort_Nestable (Self_ID); - STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); - end Lock_AST; - - ---------------- - -- Unlock_AST -- - ---------------- - - procedure Unlock_AST (Self_ID : ST.Task_Id) is - begin - STPO.Unlock (AST_Lock'Access, Global_Lock => True); - STI.Undefer_Abort_Nestable (Self_ID); - end Unlock_AST; - - --------------------------------- - -- AST_Handler Data Structures -- - --------------------------------- - - -- As noted in the private part of the spec of System.Aux_DEC, the - -- AST_Handler type is simply a pointer to a procedure that takes - -- a single 64bit parameter. The following is a local copy - -- of that definition. - - -- We need our own copy because we need to get our hands on this - -- and we cannot see the private part of System.Aux_DEC. We don't - -- want to be a child of Aux_Dec because of complications resulting - -- from the use of pragma Extend_System. We will use unchecked - -- conversions between the two versions of the declarations. - - type AST_Handler is access procedure (Param : Long_Integer); - - -- However, this declaration is somewhat misleading, since the values - -- referenced by AST_Handler values (all produced in this package by - -- calls to Create_AST_Handler) are highly stylized. - - -- The first point is that in VMS/Alpha, procedure pointers do not in - -- fact point to code, but rather to a 48-byte procedure descriptor. - -- So a value of type AST_Handler is in fact a pointer to one of these - -- 48-byte descriptors. - - type Descriptor_Type is new SSE.Storage_Array (1 .. 48); - for Descriptor_Type'Alignment use Standard'Maximum_Alignment; - - type Descriptor_Ref is access all Descriptor_Type; - - -- Normally, there is only one such descriptor for a given procedure, but - -- it works fine to make a copy of the single allocated descriptor, and - -- use the copy itself, and we take advantage of this in the design here. - -- The idea is that AST_Handler values will all point to a record with the - -- following structure: - - -- Note: When we say it works fine, there is one delicate point, which - -- is that the code for the AST procedure itself requires the original - -- descriptor address. We handle this by saving the original descriptor - -- address in this structure and restoring in Process_AST. - - type AST_Handler_Data is record - Descriptor : Descriptor_Type; - Original_Descriptor_Ref : Descriptor_Ref; - Taskid : ATID.Task_Id; - Entryno : Natural; - end record; - - type AST_Handler_Data_Ref is access all AST_Handler_Data; - - function To_AST_Handler is new Ada.Unchecked_Conversion - (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); - - -- Each time Create_AST_Handler is called, a new value of this record - -- type is created, containing a copy of the procedure descriptor for - -- the routine used to handle all AST's (Process_AST), and the Task_Id - -- and entry number parameters identifying the task entry involved. - - -- The AST_Handler value returned is a pointer to this record. Since - -- the record starts with the procedure descriptor, it can be used - -- by the system in the normal way to call the procedure. But now - -- when the procedure gets control, it can determine the address of - -- the procedure descriptor used to call it (since the ABI specifies - -- that this is left sitting in register r27 on entry), and then use - -- that address to retrieve the Task_Id and entry number so that it - -- knows on which entry to queue the AST request. - - -- The next issue is where are these records placed. Since we intend - -- to pass pointers to these records to asynchronous system service - -- routines, they have to be on the heap, which means we have to worry - -- about when to allocate them and deallocate them. - - -- We solve this problem by introducing a task attribute that points to - -- a vector, indexed by the entry number, of AST_Handler_Data records - -- for a given task. The pointer itself is a controlled object allowing - -- us to write a finalization routine that frees the referenced vector. - - -- An entry in this vector is either initialized (Entryno non-zero) and - -- can be used for any subsequent reference to the same entry, or it is - -- unused, marked by the Entryno value being zero. - - type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; - type AST_Handler_Vector_Ref is access all AST_Handler_Vector; - - type AST_Vector_Ptr is new Ada.Finalization.Controlled with record - Vector : AST_Handler_Vector_Ref; - end record; - - procedure Finalize (Obj : in out AST_Vector_Ptr); - -- Override Finalize so that the AST Vector gets freed. - - procedure Finalize (Obj : in out AST_Vector_Ptr) is - procedure Free is new - Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); - begin - if Obj.Vector /= null then - Free (Obj.Vector); - end if; - end Finalize; - - AST_Vector_Init : AST_Vector_Ptr; - -- Initial value, treated as constant, Vector will be null - - package AST_Attribute is new Ada.Task_Attributes - (Attribute => AST_Vector_Ptr, - Initial_Value => AST_Vector_Init); - - use AST_Attribute; - - ----------------------- - -- AST Service Queue -- - ----------------------- - - -- The following global data structures are used to queue pending - -- AST requests. When an AST is signalled, the AST service routine - -- Process_AST is called, and it makes an entry in this structure. - - type AST_Instance is record - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : Long_Integer; - end record; - -- The Taskid and Entryno indicate the entry on which this AST is to - -- be queued, and Param is the parameter provided from the AST itself. - - AST_Service_Queue_Size : constant := 256; - AST_Service_Queue_Limit : constant := 250; - type AST_Service_Queue_Index is mod AST_Service_Queue_Size; - -- Index used to refer to entries in the circular buffer which holds - -- active AST_Instance values. The upper bound reflects the maximum - -- number of AST instances that can be stored in the buffer. Since - -- these entries are immediately serviced by the high priority server - -- task that does the actual entry queuing, it is very unusual to have - -- any significant number of entries simultaneously queued. - - AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; - pragma Volatile_Components (AST_Service_Queue); - -- The circular buffer used to store active AST requests - - AST_Service_Queue_Put : AST_Service_Queue_Index := 0; - AST_Service_Queue_Get : AST_Service_Queue_Index := 0; - pragma Atomic (AST_Service_Queue_Put); - pragma Atomic (AST_Service_Queue_Get); - -- These two variables point to the next slots in the AST_Service_Queue - -- to be used for putting a new entry in and taking an entry out. This - -- is a circular buffer, so these pointers wrap around. If the two values - -- are equal the buffer is currently empty. The pointers are atomic to - -- ensure proper synchronization between the single producer (namely the - -- Process_AST procedure), and the single consumer (the AST_Service_Task). - - -------------------------------- - -- AST Server Task Structures -- - -------------------------------- - - -- The basic approach is that when an AST comes in, a call is made to - -- the Process_AST procedure. It queues the request in the service queue - -- and then wakes up an AST server task to perform the actual call to the - -- required entry. We use this intermediate server task, since the AST - -- procedure itself cannot wait to return, and we need some caller for - -- the rendezvous so that we can use the normal rendezvous mechanism. - - -- It would work to have only one AST server task, but then we would lose - -- all overlap in AST processing, and furthermore, we could get priority - -- inversion effects resulting in starvation of AST requests. - - -- We therefore maintain a small pool of AST server tasks. We adjust - -- the size of the pool dynamically to reflect traffic, so that we have - -- a sufficient number of server tasks to avoid starvation. - - Max_AST_Servers : constant Natural := 16; - -- Maximum number of AST server tasks that can be allocated - - Num_AST_Servers : Natural := 0; - -- Number of AST server tasks currently active - - Num_Waiting_AST_Servers : Natural := 0; - -- This is the number of AST server tasks that are either waiting for - -- work, or just about to go to sleep and wait for work. - - Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); - -- An array of flags showing which AST server tasks are currently waiting - - AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; - -- Task Id's of allocated AST server tasks - - task type AST_Server_Task (Num : Natural) is - pragma Priority (Priority'Last); - end AST_Server_Task; - -- Declaration for AST server task. This task has no entries, it is - -- controlled by sleep and wakeup calls at the task primitives level. - - type AST_Server_Task_Ptr is access all AST_Server_Task; - -- Type used to allocate server tasks - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate_New_AST_Server; - -- Allocate an additional AST server task - - procedure Process_AST (Param : Long_Integer); - -- This is the central routine for processing all AST's, it is referenced - -- as the code address of all created AST_Handler values. See detailed - -- description in body to understand how it works to have a single such - -- procedure for all AST's even though it does not get any indication of - -- the entry involved passed as an explicit parameter. The single explicit - -- parameter Param is the parameter passed by the system with the AST. - - ----------------------------- - -- Allocate_New_AST_Server -- - ----------------------------- - - procedure Allocate_New_AST_Server is - Dummy : AST_Server_Task_Ptr; - pragma Unreferenced (Dummy); - - begin - if Num_AST_Servers = Max_AST_Servers then - return; - - else - -- Note: it is safe to increment Num_AST_Servers immediately, since - -- no one will try to activate this task until it indicates that it - -- is sleeping by setting its entry in Is_Waiting to True. - - Num_AST_Servers := Num_AST_Servers + 1; - Dummy := new AST_Server_Task (Num_AST_Servers); - end if; - end Allocate_New_AST_Server; - - --------------------- - -- AST_Server_Task -- - --------------------- - - task body AST_Server_Task is - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : aliased Long_Integer; - Self_Id : constant ST.Task_Id := ST.Self; - - pragma Volatile (Param); - - begin - -- By making this task independent of master, when the environment - -- task is finalizing, the AST_Server_Task will be notified that it - -- should terminate. - - STU.Make_Independent; - - -- Record our task Id for access by Process_AST - - AST_Task_Ids (Num) := Self_Id; - - -- Note: this entire task operates with the main task lock set, except - -- when it is sleeping waiting for work, or busy doing a rendezvous - -- with an AST server. This lock protects the data structures that - -- are shared by multiple instances of the server task. - - Lock_AST (Self_Id); - - -- This is the main infinite loop of the task. We go to sleep and - -- wait to be woken up by Process_AST when there is some work to do. - - loop - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; - - Unlock_AST (Self_Id); - - STI.Defer_Abort (Self_Id); - - if SP.Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - Is_Waiting (Num) := True; - - Self_Id.Common.State := ST.AST_Server_Sleep; - STPO.Sleep (Self_Id, ST.AST_Server_Sleep); - Self_Id.Common.State := ST.Runnable; - - STPO.Unlock (Self_Id); - - if SP.Single_Lock then - STPO.Unlock_RTS; - end if; - - -- If the process is finalizing, Undefer_Abort will simply end - -- this task. - - STI.Undefer_Abort (Self_Id); - - -- We are awake, there is something to do - - Lock_AST (Self_Id); - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; - - -- Loop here to service outstanding requests. We are always - -- locked on entry to this loop. - - while AST_Service_Queue_Get /= AST_Service_Queue_Put loop - Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; - Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; - Param := AST_Service_Queue (AST_Service_Queue_Get).Param; - - AST_Service_Queue_Get := AST_Service_Queue_Get + 1; - - -- This is a manual expansion of the normal call simple code - - declare - type AA is access all Long_Integer; - P : AA := Param'Unrestricted_Access; - - function To_ST_Task_Id is new Ada.Unchecked_Conversion - (ATID.Task_Id, ST.Task_Id); - - begin - Unlock_AST (Self_Id); - STR.Call_Simple - (Acceptor => To_ST_Task_Id (Taskid), - E => ST.Task_Entry_Index (Entryno), - Uninterpreted_Data => P'Address); - - exception - when E : others => - System.IO.Put_Line ("%Debugging event"); - System.IO.Put_Line (Exception_Name (E) & - " raised when trying to deliver an AST."); - - if Exception_Message (E)'Length /= 0 then - System.IO.Put_Line (Exception_Message (E)); - end if; - - System.IO.Put_Line ("Task type is " & "Receiver_Type"); - System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); - end; - - Lock_AST (Self_Id); - end loop; - end loop; - end AST_Server_Task; - - ------------------------ - -- Create_AST_Handler -- - ------------------------ - - function Create_AST_Handler - (Taskid : ATID.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler - is - Attr_Ref : Attribute_Handle; - - Process_AST_Ptr : constant AST_Handler := Process_AST'Access; - -- Reference to standard procedure descriptor for Process_AST - - pragma Warnings (Off, "*alignment*"); - -- Suppress harmless warnings about alignment. - -- Should explain why this warning is harmless ??? - - function To_Descriptor_Ref is new Ada.Unchecked_Conversion - (AST_Handler, Descriptor_Ref); - - Original_Descriptor_Ref : constant Descriptor_Ref := - To_Descriptor_Ref (Process_AST_Ptr); - - pragma Warnings (On, "*alignment*"); - - begin - if ATID.Is_Terminated (Taskid) then - raise Program_Error; - end if; - - Attr_Ref := Reference (Taskid); - - -- Allocate another server if supply is getting low - - if Num_Waiting_AST_Servers < 2 then - Allocate_New_AST_Server; - end if; - - -- No point in creating more if we have zillions waiting to - -- be serviced. - - while AST_Service_Queue_Put - AST_Service_Queue_Get - > AST_Service_Queue_Limit - loop - delay 0.01; - end loop; - - -- If no AST vector allocated, or the one we have is too short, then - -- allocate one of right size and initialize all entries except the - -- one we will use to unused. Note that the assignment automatically - -- frees the old allocated table if there is one. - - if Attr_Ref.Vector = null - or else Attr_Ref.Vector'Length < Entryno - then - Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); - - for E in 1 .. Entryno loop - Attr_Ref.Vector (E).Descriptor := - Original_Descriptor_Ref.all; - Attr_Ref.Vector (E).Original_Descriptor_Ref := - Original_Descriptor_Ref; - Attr_Ref.Vector (E).Taskid := Taskid; - Attr_Ref.Vector (E).Entryno := E; - end loop; - end if; - - return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); - end Create_AST_Handler; - - ---------------------------- - -- Expand_AST_Packet_Pool -- - ---------------------------- - - procedure Expand_AST_Packet_Pool - (Requested_Packets : Natural; - Actual_Number : out Natural; - Total_Number : out Natural) - is - pragma Unreferenced (Requested_Packets); - begin - -- The AST implementation of GNAT does not permit dynamic expansion - -- of the pool, so we simply add no entries and return the total. If - -- it is necessary to expand the allocation, then this package body - -- must be recompiled with a larger value for AST_Service_Queue_Size. - - Actual_Number := 0; - Total_Number := AST_Service_Queue_Size; - end Expand_AST_Packet_Pool; - - ----------------- - -- Process_AST -- - ----------------- - - procedure Process_AST (Param : Long_Integer) is - - Handler_Data_Ptr : AST_Handler_Data_Ref; - -- This variable is set to the address of the descriptor through - -- which Process_AST is called. Since the descriptor is part of - -- an AST_Handler value, this is also the address of this value, - -- from which we can obtain the task and entry number information. - - function To_Address is new Ada.Unchecked_Conversion - (ST.Task_Id, System.Task_Primitives.Task_Address); - - begin - System.Machine_Code.Asm - (Template => "addq $27,0,%0", - Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), - Volatile => True); - - System.Machine_Code.Asm - (Template => "ldq $27,%0", - Inputs => Descriptor_Ref'Asm_Input - ("m", Handler_Data_Ptr.Original_Descriptor_Ref), - Volatile => True); - - AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' - (Taskid => Handler_Data_Ptr.Taskid, - Entryno => Handler_Data_Ptr.Entryno, - Param => Param); - - -- OpenVMS Programming Concepts manual, chapter 8.2.3: - -- "Implicit synchronization can be achieved for data that is shared - -- for write by using only AST routines to write the data, since only - -- one AST can be running at any one time." - - -- This subprogram runs at AST level so is guaranteed to be - -- called sequentially at a given access level. - - AST_Service_Queue_Put := AST_Service_Queue_Put + 1; - - -- Need to wake up processing task. If there is no waiting server - -- then we have temporarily run out, but things should still be - -- OK, since one of the active ones will eventually pick up the - -- service request queued in the AST_Service_Queue. - - for J in 1 .. Num_AST_Servers loop - if Is_Waiting (J) then - Is_Waiting (J) := False; - - -- Sleeps are handled by ASTs on VMS, so don't call Wakeup - - STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); - exit; - end if; - end loop; - end Process_AST; - -begin - STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); -end System.AST_Handling; diff --git a/main/gcc/ada/s-asthan-vms-ia64.adb b/main/gcc/ada/s-asthan-vms-ia64.adb deleted file mode 100644 index 0f16fe8e331..00000000000 --- a/main/gcc/ada/s-asthan-vms-ia64.adb +++ /dev/null @@ -1,608 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS/IA64 version - -with System; use System; - -with System.IO; - -with System.Machine_Code; -with System.Parameters; - -with System.Tasking; -with System.Tasking.Rendezvous; -with System.Tasking.Initialization; -with System.Tasking.Utilities; - -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - -with Ada.Finalization; -with Ada.Task_Attributes; - -with Ada.Exceptions; use Ada.Exceptions; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body System.AST_Handling is - - package ATID renames Ada.Task_Identification; - - package SP renames System.Parameters; - package ST renames System.Tasking; - package STR renames System.Tasking.Rendezvous; - package STI renames System.Tasking.Initialization; - package STU renames System.Tasking.Utilities; - - package STPO renames System.Task_Primitives.Operations; - package STPOD renames System.Task_Primitives.Operations.DEC; - - AST_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion - -- from all other AST tasks. It is only used by Lock_AST and - -- Unlock_AST. - - procedure Lock_AST (Self_ID : ST.Task_Id); - -- Locks out other AST tasks. Preceding a section of code by Lock_AST and - -- following it by Unlock_AST creates a critical region. - - procedure Unlock_AST (Self_ID : ST.Task_Id); - -- Releases lock previously set by call to Lock_AST. - -- All nested locks must be released before other tasks competing for the - -- tasking lock are released. - - -------------- - -- Lock_AST -- - -------------- - - procedure Lock_AST (Self_ID : ST.Task_Id) is - begin - STI.Defer_Abort_Nestable (Self_ID); - STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); - end Lock_AST; - - ---------------- - -- Unlock_AST -- - ---------------- - - procedure Unlock_AST (Self_ID : ST.Task_Id) is - begin - STPO.Unlock (AST_Lock'Access, Global_Lock => True); - STI.Undefer_Abort_Nestable (Self_ID); - end Unlock_AST; - - --------------------------------- - -- AST_Handler Data Structures -- - --------------------------------- - - -- As noted in the private part of the spec of System.Aux_DEC, the - -- AST_Handler type is simply a pointer to a procedure that takes - -- a single 64bit parameter. The following is a local copy - -- of that definition. - - -- We need our own copy because we need to get our hands on this - -- and we cannot see the private part of System.Aux_DEC. We don't - -- want to be a child of Aux_Dec because of complications resulting - -- from the use of pragma Extend_System. We will use unchecked - -- conversions between the two versions of the declarations. - - type AST_Handler is access procedure (Param : Long_Integer); - - -- However, this declaration is somewhat misleading, since the values - -- referenced by AST_Handler values (all produced in this package by - -- calls to Create_AST_Handler) are highly stylized. - - -- The first point is that in VMS/I64, procedure pointers do not in - -- fact point to code, but rather to a procedure descriptor. - -- So a value of type AST_Handler is in fact a pointer to one of - -- descriptors. - - type Descriptor_Type is - record - Entry_Point : System.Address; - GP_Value : System.Address; - end record; - for Descriptor_Type'Alignment use Standard'Maximum_Alignment; - -- pragma Warnings (Off, Descriptor_Type); - -- Suppress harmless warnings about alignment. - -- Should explain why this warning is harmless ??? - - type Descriptor_Ref is access all Descriptor_Type; - - -- Normally, there is only one such descriptor for a given procedure, but - -- it works fine to make a copy of the single allocated descriptor, and - -- use the copy itself, and we take advantage of this in the design here. - -- The idea is that AST_Handler values will all point to a record with the - -- following structure: - - -- Note: When we say it works fine, there is one delicate point, which - -- is that the code for the AST procedure itself requires the original - -- descriptor address. We handle this by saving the orignal descriptor - -- address in this structure and restoring in Process_AST. - - type AST_Handler_Data is record - Descriptor : Descriptor_Type; - Original_Descriptor_Ref : Descriptor_Ref; - Taskid : ATID.Task_Id; - Entryno : Natural; - end record; - - type AST_Handler_Data_Ref is access all AST_Handler_Data; - - function To_AST_Handler is new Ada.Unchecked_Conversion - (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); - - -- Each time Create_AST_Handler is called, a new value of this record - -- type is created, containing a copy of the procedure descriptor for - -- the routine used to handle all AST's (Process_AST), and the Task_Id - -- and entry number parameters identifying the task entry involved. - - -- The AST_Handler value returned is a pointer to this record. Since - -- the record starts with the procedure descriptor, it can be used - -- by the system in the normal way to call the procedure. But now - -- when the procedure gets control, it can determine the address of - -- the procedure descriptor used to call it (since the ABI specifies - -- that this is left sitting in register r27 on entry), and then use - -- that address to retrieve the Task_Id and entry number so that it - -- knows on which entry to queue the AST request. - - -- The next issue is where are these records placed. Since we intend - -- to pass pointers to these records to asynchronous system service - -- routines, they have to be on the heap, which means we have to worry - -- about when to allocate them and deallocate them. - - -- We solve this problem by introducing a task attribute that points to - -- a vector, indexed by the entry number, of AST_Handler_Data records - -- for a given task. The pointer itself is a controlled object allowing - -- us to write a finalization routine that frees the referenced vector. - - -- An entry in this vector is either initialized (Entryno non-zero) and - -- can be used for any subsequent reference to the same entry, or it is - -- unused, marked by the Entryno value being zero. - - type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; - type AST_Handler_Vector_Ref is access all AST_Handler_Vector; - - type AST_Vector_Ptr is new Ada.Finalization.Controlled with record - Vector : AST_Handler_Vector_Ref; - end record; - - procedure Finalize (Obj : in out AST_Vector_Ptr); - -- Override Finalize so that the AST Vector gets freed. - - procedure Finalize (Obj : in out AST_Vector_Ptr) is - procedure Free is new - Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); - begin - if Obj.Vector /= null then - Free (Obj.Vector); - end if; - end Finalize; - - AST_Vector_Init : AST_Vector_Ptr; - -- Initial value, treated as constant, Vector will be null - - package AST_Attribute is new Ada.Task_Attributes - (Attribute => AST_Vector_Ptr, - Initial_Value => AST_Vector_Init); - - use AST_Attribute; - - ----------------------- - -- AST Service Queue -- - ----------------------- - - -- The following global data structures are used to queue pending - -- AST requests. When an AST is signalled, the AST service routine - -- Process_AST is called, and it makes an entry in this structure. - - type AST_Instance is record - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : Long_Integer; - end record; - -- The Taskid and Entryno indicate the entry on which this AST is to - -- be queued, and Param is the parameter provided from the AST itself. - - AST_Service_Queue_Size : constant := 256; - AST_Service_Queue_Limit : constant := 250; - type AST_Service_Queue_Index is mod AST_Service_Queue_Size; - -- Index used to refer to entries in the circular buffer which holds - -- active AST_Instance values. The upper bound reflects the maximum - -- number of AST instances that can be stored in the buffer. Since - -- these entries are immediately serviced by the high priority server - -- task that does the actual entry queuing, it is very unusual to have - -- any significant number of entries simulaneously queued. - - AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; - pragma Volatile_Components (AST_Service_Queue); - -- The circular buffer used to store active AST requests - - AST_Service_Queue_Put : AST_Service_Queue_Index := 0; - AST_Service_Queue_Get : AST_Service_Queue_Index := 0; - pragma Atomic (AST_Service_Queue_Put); - pragma Atomic (AST_Service_Queue_Get); - -- These two variables point to the next slots in the AST_Service_Queue - -- to be used for putting a new entry in and taking an entry out. This - -- is a circular buffer, so these pointers wrap around. If the two values - -- are equal the buffer is currently empty. The pointers are atomic to - -- ensure proper synchronization between the single producer (namely the - -- Process_AST procedure), and the single consumer (the AST_Service_Task). - - -------------------------------- - -- AST Server Task Structures -- - -------------------------------- - - -- The basic approach is that when an AST comes in, a call is made to - -- the Process_AST procedure. It queues the request in the service queue - -- and then wakes up an AST server task to perform the actual call to the - -- required entry. We use this intermediate server task, since the AST - -- procedure itself cannot wait to return, and we need some caller for - -- the rendezvous so that we can use the normal rendezvous mechanism. - - -- It would work to have only one AST server task, but then we would lose - -- all overlap in AST processing, and furthermore, we could get priority - -- inversion effects resulting in starvation of AST requests. - - -- We therefore maintain a small pool of AST server tasks. We adjust - -- the size of the pool dynamically to reflect traffic, so that we have - -- a sufficient number of server tasks to avoid starvation. - - Max_AST_Servers : constant Natural := 16; - -- Maximum number of AST server tasks that can be allocated - - Num_AST_Servers : Natural := 0; - -- Number of AST server tasks currently active - - Num_Waiting_AST_Servers : Natural := 0; - -- This is the number of AST server tasks that are either waiting for - -- work, or just about to go to sleep and wait for work. - - Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); - -- An array of flags showing which AST server tasks are currently waiting - - AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; - -- Task Id's of allocated AST server tasks - - task type AST_Server_Task (Num : Natural) is - pragma Priority (Priority'Last); - end AST_Server_Task; - -- Declaration for AST server task. This task has no entries, it is - -- controlled by sleep and wakeup calls at the task primitives level. - - type AST_Server_Task_Ptr is access all AST_Server_Task; - -- Type used to allocate server tasks - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate_New_AST_Server; - -- Allocate an additional AST server task - - procedure Process_AST (Param : Long_Integer); - -- This is the central routine for processing all AST's, it is referenced - -- as the code address of all created AST_Handler values. See detailed - -- description in body to understand how it works to have a single such - -- procedure for all AST's even though it does not get any indication of - -- the entry involved passed as an explicit parameter. The single explicit - -- parameter Param is the parameter passed by the system with the AST. - - ----------------------------- - -- Allocate_New_AST_Server -- - ----------------------------- - - procedure Allocate_New_AST_Server is - Dummy : AST_Server_Task_Ptr; - pragma Unreferenced (Dummy); - - begin - if Num_AST_Servers = Max_AST_Servers then - return; - - else - -- Note: it is safe to increment Num_AST_Servers immediately, since - -- no one will try to activate this task until it indicates that it - -- is sleeping by setting its entry in Is_Waiting to True. - - Num_AST_Servers := Num_AST_Servers + 1; - Dummy := new AST_Server_Task (Num_AST_Servers); - end if; - end Allocate_New_AST_Server; - - --------------------- - -- AST_Server_Task -- - --------------------- - - task body AST_Server_Task is - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : aliased Long_Integer; - Self_Id : constant ST.Task_Id := ST.Self; - - pragma Volatile (Param); - - begin - -- By making this task independent of master, when the environment - -- task is finalizing, the AST_Server_Task will be notified that it - -- should terminate. - - STU.Make_Independent; - - -- Record our task Id for access by Process_AST - - AST_Task_Ids (Num) := Self_Id; - - -- Note: this entire task operates with the main task lock set, except - -- when it is sleeping waiting for work, or busy doing a rendezvous - -- with an AST server. This lock protects the data structures that - -- are shared by multiple instances of the server task. - - Lock_AST (Self_Id); - - -- This is the main infinite loop of the task. We go to sleep and - -- wait to be woken up by Process_AST when there is some work to do. - - loop - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; - - Unlock_AST (Self_Id); - - STI.Defer_Abort (Self_Id); - - if SP.Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - Is_Waiting (Num) := True; - - Self_Id.Common.State := ST.AST_Server_Sleep; - STPO.Sleep (Self_Id, ST.AST_Server_Sleep); - Self_Id.Common.State := ST.Runnable; - - STPO.Unlock (Self_Id); - - if SP.Single_Lock then - STPO.Unlock_RTS; - end if; - - -- If the process is finalizing, Undefer_Abort will simply end - -- this task. - - STI.Undefer_Abort (Self_Id); - - -- We are awake, there is something to do - - Lock_AST (Self_Id); - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; - - -- Loop here to service outstanding requests. We are always - -- locked on entry to this loop. - - while AST_Service_Queue_Get /= AST_Service_Queue_Put loop - Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; - Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; - Param := AST_Service_Queue (AST_Service_Queue_Get).Param; - - AST_Service_Queue_Get := AST_Service_Queue_Get + 1; - - -- This is a manual expansion of the normal call simple code - - declare - type AA is access all Long_Integer; - P : AA := Param'Unrestricted_Access; - - function To_ST_Task_Id is new Ada.Unchecked_Conversion - (ATID.Task_Id, ST.Task_Id); - - begin - Unlock_AST (Self_Id); - STR.Call_Simple - (Acceptor => To_ST_Task_Id (Taskid), - E => ST.Task_Entry_Index (Entryno), - Uninterpreted_Data => P'Address); - - exception - when E : others => - System.IO.Put_Line ("%Debugging event"); - System.IO.Put_Line (Exception_Name (E) & - " raised when trying to deliver an AST."); - - if Exception_Message (E)'Length /= 0 then - System.IO.Put_Line (Exception_Message (E)); - end if; - - System.IO.Put_Line ("Task type is " & "Receiver_Type"); - System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); - end; - - Lock_AST (Self_Id); - end loop; - end loop; - end AST_Server_Task; - - ------------------------ - -- Create_AST_Handler -- - ------------------------ - - function Create_AST_Handler - (Taskid : ATID.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler - is - Attr_Ref : Attribute_Handle; - - Process_AST_Ptr : constant AST_Handler := Process_AST'Access; - -- Reference to standard procedure descriptor for Process_AST - - function To_Descriptor_Ref is new Ada.Unchecked_Conversion - (AST_Handler, Descriptor_Ref); - - Original_Descriptor_Ref : constant Descriptor_Ref := - To_Descriptor_Ref (Process_AST_Ptr); - - begin - if ATID.Is_Terminated (Taskid) then - raise Program_Error; - end if; - - Attr_Ref := Reference (Taskid); - - -- Allocate another server if supply is getting low - - if Num_Waiting_AST_Servers < 2 then - Allocate_New_AST_Server; - end if; - - -- No point in creating more if we have zillions waiting to - -- be serviced. - - while AST_Service_Queue_Put - AST_Service_Queue_Get - > AST_Service_Queue_Limit - loop - delay 0.01; - end loop; - - -- If no AST vector allocated, or the one we have is too short, then - -- allocate one of right size and initialize all entries except the - -- one we will use to unused. Note that the assignment automatically - -- frees the old allocated table if there is one. - - if Attr_Ref.Vector = null - or else Attr_Ref.Vector'Length < Entryno - then - Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); - - for E in 1 .. Entryno loop - Attr_Ref.Vector (E).Descriptor.Entry_Point := - Original_Descriptor_Ref.Entry_Point; - Attr_Ref.Vector (E).Descriptor.GP_Value := - Attr_Ref.Vector (E)'Address; - Attr_Ref.Vector (E).Original_Descriptor_Ref := - Original_Descriptor_Ref; - Attr_Ref.Vector (E).Taskid := Taskid; - Attr_Ref.Vector (E).Entryno := E; - end loop; - end if; - - return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); - end Create_AST_Handler; - - ---------------------------- - -- Expand_AST_Packet_Pool -- - ---------------------------- - - procedure Expand_AST_Packet_Pool - (Requested_Packets : Natural; - Actual_Number : out Natural; - Total_Number : out Natural) - is - pragma Unreferenced (Requested_Packets); - begin - -- The AST implementation of GNAT does not permit dynamic expansion - -- of the pool, so we simply add no entries and return the total. If - -- it is necessary to expand the allocation, then this package body - -- must be recompiled with a larger value for AST_Service_Queue_Size. - - Actual_Number := 0; - Total_Number := AST_Service_Queue_Size; - end Expand_AST_Packet_Pool; - - ----------------- - -- Process_AST -- - ----------------- - - procedure Process_AST (Param : Long_Integer) is - - Handler_Data_Ptr : AST_Handler_Data_Ref; - -- This variable is set to the address of the descriptor through - -- which Process_AST is called. Since the descriptor is part of - -- an AST_Handler value, this is also the address of this value, - -- from which we can obtain the task and entry number information. - - function To_Address is new Ada.Unchecked_Conversion - (ST.Task_Id, System.Task_Primitives.Task_Address); - - begin - -- Move the contrived GP into place so Taskid and Entryno - -- become available, then restore the true GP. - - System.Machine_Code.Asm - (Template => "mov %0 = r1", - Outputs => AST_Handler_Data_Ref'Asm_Output - ("=r", Handler_Data_Ptr), - Volatile => True); - - System.Machine_Code.Asm - (Template => "ld8 r1 = %0;;", - Inputs => System.Address'Asm_Input - ("m", Handler_Data_Ptr.Original_Descriptor_Ref.GP_Value), - Volatile => True); - - AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' - (Taskid => Handler_Data_Ptr.Taskid, - Entryno => Handler_Data_Ptr.Entryno, - Param => Param); - - -- OpenVMS Programming Concepts manual, chapter 8.2.3: - -- "Implicit synchronization can be achieved for data that is shared - -- for write by using only AST routines to write the data, since only - -- one AST can be running at any one time." - - -- This subprogram runs at AST level so is guaranteed to be - -- called sequentially at a given access level. - - AST_Service_Queue_Put := AST_Service_Queue_Put + 1; - - -- Need to wake up processing task. If there is no waiting server - -- then we have temporarily run out, but things should still be - -- OK, since one of the active ones will eventually pick up the - -- service request queued in the AST_Service_Queue. - - for J in 1 .. Num_AST_Servers loop - if Is_Waiting (J) then - Is_Waiting (J) := False; - - -- Sleeps are handled by ASTs on VMS, so don't call Wakeup - - STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); - exit; - end if; - end loop; - end Process_AST; - -begin - STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); -end System.AST_Handling; diff --git a/main/gcc/ada/s-asthan.adb b/main/gcc/ada/s-asthan.adb deleted file mode 100644 index 5cce4103f99..00000000000 --- a/main/gcc/ada/s-asthan.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUNT-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the dummy version used on non-VMS systems - -package body System.AST_Handling is - - ------------------------ - -- Create_AST_Handler -- - ------------------------ - - function Create_AST_Handler - (Taskid : Ada.Task_Identification.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler - is - begin - raise Program_Error with "AST is implemented only on VMS systems"; - return System.Aux_DEC.No_AST_Handler; - end Create_AST_Handler; - - procedure Expand_AST_Packet_Pool - (Requested_Packets : Natural; - Actual_Number : out Natural; - Total_Number : out Natural) - is - begin - raise Program_Error with "AST is implemented only on VMS systems"; - end Expand_AST_Packet_Pool; - -end System.AST_Handling; diff --git a/main/gcc/ada/s-asthan.ads b/main/gcc/ada/s-asthan.ads deleted file mode 100644 index 6ee2228df4d..00000000000 --- a/main/gcc/ada/s-asthan.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Runtime support for Handling of AST's (Used on VMS implementations only) - -with Ada.Task_Identification; -with System; -with System.Aux_DEC; - -package System.AST_Handling is - - function Create_AST_Handler - (Taskid : Ada.Task_Identification.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler; - -- This function implements the appropriate semantics for a use of the - -- AST_Entry pragma. See body for details of implementation approach. - -- The parameters are the Task_Id for the task containing the entry - -- and the entry Index for the specified entry. - - procedure Expand_AST_Packet_Pool - (Requested_Packets : Natural; - Actual_Number : out Natural; - Total_Number : out Natural); - -- This function takes a request for zero or more extra AST packets and - -- returns the number actually added to the pool and the total number - -- now available or in use. - -- This function is not yet fully implemented. - -end System.AST_Handling; diff --git a/main/gcc/ada/s-auxdec-vms-alpha.adb b/main/gcc/ada/s-auxdec-vms-alpha.adb deleted file mode 100644 index 4116e32b355..00000000000 --- a/main/gcc/ada/s-auxdec-vms-alpha.adb +++ /dev/null @@ -1,809 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version. - -pragma Style_Checks (All_Checks); --- Turn off alpha ordering check on subprograms, this unit is laid --- out to correspond to the declarations in the DEC 83 System unit. - -with System.Machine_Code; use System.Machine_Code; -package body System.Aux_DEC is - - ------------------------ - -- Fetch_From_Address -- - ------------------------ - - function Fetch_From_Address (A : Address) return Target is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - return Ptr.all; - end Fetch_From_Address; - - ----------------------- - -- Assign_To_Address -- - ----------------------- - - procedure Assign_To_Address (A : Address; T : Target) is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - Ptr.all := T; - end Assign_To_Address; - - ----------------------- - -- Clear_Interlocked -- - ----------------------- - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - use ASCII; - Clr_Bit : Boolean := Bit; - Old_Bit : Boolean; - - begin - -- All these ASM sequences should be commented. I suggest defining - -- a constant called E which is LF & HT and then you have more space - -- for line by line comments ??? - - System.Machine_Code.Asm - ( - "lda $16, %2" & LF & HT & - "mb" & LF & HT & - "sll $16, 3, $17 " & LF & HT & - "bis $31, 1, $1" & LF & HT & - "and $17, 63, $18" & LF & HT & - "bic $17, 63, $17" & LF & HT & - "sra $17, 3, $17" & LF & HT & - "bis $31, 1, %1" & LF & HT & - "sll %1, $18, $18" & LF & HT & - "1:" & LF & HT & - "ldq_l $1, 0($17)" & LF & HT & - "and $1, $18, %1" & LF & HT & - "bic $1, $18, $1" & LF & HT & - "stq_c $1, 0($17)" & LF & HT & - "cmpeq %1, 0, %1" & LF & HT & - "beq $1, 1b" & LF & HT & - "mb" & LF & HT & - "xor %1, 1, %1" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), - Boolean'Asm_Output ("=r", Old_Bit)), - Inputs => Boolean'Asm_Input ("m", Clr_Bit), - Clobber => "$1, $16, $17, $18", - Volatile => True); - - Bit := Clr_Bit; - Old_Value := Old_Bit; - end Clear_Interlocked; - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - use ASCII; - Clr_Bit : Boolean := Bit; - Succ, Old_Bit : Boolean; - - begin - System.Machine_Code.Asm - ( - "lda $16, %3" & LF & HT & - "mb" & LF & HT & - "sll $16, 3, $18 " & LF & HT & - "bis $31, 1, %1" & LF & HT & - "and $18, 63, $19" & LF & HT & - "bic $18, 63, $18" & LF & HT & - "sra $18, 3, $18" & LF & HT & - "bis $31, %4, $17" & LF & HT & - "sll %1, $19, $19" & LF & HT & - "1:" & LF & HT & - "ldq_l %2, 0($18)" & LF & HT & - "and %2, $19, %1" & LF & HT & - "bic %2, $19, %2" & LF & HT & - "stq_c %2, 0($18)" & LF & HT & - "beq %2, 2f" & LF & HT & - "cmpeq %1, 0, %1" & LF & HT & - "br 3f" & LF & HT & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "3:" & LF & HT & - "mb" & LF & HT & - "xor %1, 1, %1" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), - Boolean'Asm_Output ("=r", Old_Bit), - Boolean'Asm_Output ("=r", Succ)), - Inputs => (Boolean'Asm_Input ("m", Clr_Bit), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$16, $17, $18, $19", - Volatile => True); - - Bit := Clr_Bit; - Old_Value := Old_Bit; - Success_Flag := Succ; - end Clear_Interlocked; - - --------------------- - -- Set_Interlocked -- - --------------------- - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - use ASCII; - Set_Bit : Boolean := Bit; - Old_Bit : Boolean; - - begin - -- Don't we need comments on these long asm sequences??? - - System.Machine_Code.Asm - ( - "lda $16, %2" & LF & HT & - "sll $16, 3, $17 " & LF & HT & - "bis $31, 1, $1" & LF & HT & - "and $17, 63, $18" & LF & HT & - "mb" & LF & HT & - "bic $17, 63, $17" & LF & HT & - "sra $17, 3, $17" & LF & HT & - "bis $31, 1, %1" & LF & HT & - "sll %1, $18, $18" & LF & HT & - "1:" & LF & HT & - "ldq_l $1, 0($17)" & LF & HT & - "and $1, $18, %1" & LF & HT & - "bis $1, $18, $1" & LF & HT & - "stq_c $1, 0($17)" & LF & HT & - "cmovne %1, 1, %1" & LF & HT & - "beq $1, 1b" & LF & HT & - "mb" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Set_Bit), - Boolean'Asm_Output ("=r", Old_Bit)), - Inputs => Boolean'Asm_Input ("m", Set_Bit), - Clobber => "$1, $16, $17, $18", - Volatile => True); - - Bit := Set_Bit; - Old_Value := Old_Bit; - end Set_Interlocked; - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - use ASCII; - Set_Bit : Boolean := Bit; - Succ, Old_Bit : Boolean; - - begin - System.Machine_Code.Asm - ( - "lda $16, %3" & LF & HT & -- Address of Bit - "mb" & LF & HT & - "sll $16, 3, $18 " & LF & HT & -- Byte address to bit address - "bis $31, 1, %1" & LF & HT & -- Set temp to 1 for the sll - "and $18, 63, $19" & LF & HT & -- Quadword bit offset - "bic $18, 63, $18" & LF & HT & -- Quadword bit address - "sra $18, 3, $18" & LF & HT & -- Quadword address - "bis $31, %4, $17" & LF & HT & -- Retry_Count -> $17 - "sll %1, $19, $19" & LF & -- $19 = 1 << bit_offset - "1:" & LF & HT & - "ldq_l %2, 0($18)" & LF & HT & -- Load & lock - "and %2, $19, %1" & LF & HT & -- Previous value -> %1 - "bis %2, $19, %2" & LF & HT & -- Set Bit - "stq_c %2, 0($18)" & LF & HT & -- Store conditional - "beq %2, 2f" & LF & HT & -- Goto 2: if failed - "cmovne %1, 1, %1" & LF & HT & -- Set Old_Bit - "br 3f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & -- Retry_Count - 1 - "bgt $17, 1b" & LF & -- Retry ? - "3:" & LF & HT & - "mb" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Set_Bit), - Boolean'Asm_Output ("=r", Old_Bit), - Boolean'Asm_Output ("=r", Succ)), - Inputs => (Boolean'Asm_Input ("m", Set_Bit), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$16, $17, $18, $19", - Volatile => True); - - Bit := Set_Bit; - Old_Value := Old_Bit; - Success_Flag := Succ; - end Set_Interlocked; - - --------------------- - -- Add_Interlocked -- - --------------------- - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer) - is - use ASCII; - Overflowed : Boolean := False; - - begin - System.Machine_Code.Asm - ( - "lda $18, %0" & LF & HT & - "bic $18, 6, $21" & LF & HT & - "mb" & LF & HT & - "1:" & LF & HT & - "ldq_l $0, 0($21)" & LF & HT & - "extwl $0, $18, $19" & LF & HT & - "mskwl $0, $18, $0" & LF & HT & - "addq $19, %3, $20" & LF & HT & - "inswl $20, $18, $17" & LF & HT & - "xor $19, %3, $19" & LF & HT & - "bis $17, $0, $0" & LF & HT & - "stq_c $0, 0($21)" & LF & HT & - "beq $0, 1b" & LF & HT & - "srl $20, 16, $0" & LF & HT & - "mb" & LF & HT & - "srl $20, 12, $21" & LF & HT & - "zapnot $20, 3, $20" & LF & HT & - "and $0, 1, $0" & LF & HT & - "and $21, 8, $21" & LF & HT & - "bis $21, $0, $0" & LF & HT & - "cmpeq $20, 0, $21" & LF & HT & - "xor $20, 2, $20" & LF & HT & - "sll $21, 2, $21" & LF & HT & - "bis $21, $0, $0" & LF & HT & - "bic $20, $19, $21" & LF & HT & - "srl $21, 14, $21" & LF & HT & - "and $21, 2, $21" & LF & HT & - "bis $21, $0, $0" & LF & HT & - "and $0, 2, %2" & LF & HT & - "bne %2, 2f" & LF & HT & - "and $0, 4, %1" & LF & HT & - "cmpeq %1, 0, %1" & LF & HT & - "and $0, 8, $0" & LF & HT & - "lda $16, -1" & LF & HT & - "cmovne $0, $16, %1" & LF & HT & - "2:", - Outputs => (Aligned_Word'Asm_Output ("=m", Augend), - Integer'Asm_Output ("=r", Sign), - Boolean'Asm_Output ("=r", Overflowed)), - Inputs => (Short_Integer'Asm_Input ("r", Addend), - Aligned_Word'Asm_Input ("m", Augend)), - Clobber => "$0, $1, $16, $17, $18, $19, $20, $21", - Volatile => True); - - if Overflowed then - raise Constraint_Error; - end if; - end Add_Interlocked; - - ---------------- - -- Add_Atomic -- - ---------------- - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "addl $1, %2, $0" & LF & HT & - "stl_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", Amount)), - Clobber => "$0, $1", - Volatile => True); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "addl $1, %4, $0" & LF & HT & - "stl_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stl $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Integer'Asm_Output ("=m", To), - Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", Amount), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "addq $1, %2, $0" & LF & HT & - "stq_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", Amount)), - Clobber => "$0, $1", - Volatile => True); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "addq $1, %4, $0" & LF & HT & - "stq_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stq $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), - Long_Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", Amount), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Add_Atomic; - - ---------------- - -- And_Atomic -- - ---------------- - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "and $1, %2, $0" & LF & HT & - "stl_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "and $1, %4, $0" & LF & HT & - "stl_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stl $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Integer'Asm_Output ("=m", To), - Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "and $1, %2, $0" & LF & HT & - "stq_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "and $1, %4, $0" & LF & HT & - "stq_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stq $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), - Long_Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end And_Atomic; - - --------------- - -- Or_Atomic -- - --------------- - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "bis $1, %2, $0" & LF & HT & - "stl_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "bis $1, %4, $0" & LF & HT & - "stl_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stl $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Integer'Asm_Output ("=m", To), - Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "bis $1, %2, $0" & LF & HT & - "stq_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "bis $1, %4, $0" & LF & HT & - "stq_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stq $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), - Long_Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Or_Atomic; - - ------------ - -- Insqhi -- - ------------ - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %1, $17" & LF & HT & - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x87" & LF & HT & - "mb", - Outputs => Insq_Status'Asm_Output ("=v", Status), - Inputs => (Address'Asm_Input ("rJ", Item), - Address'Asm_Input ("rJ", Header)), - Clobber => "$16, $17", - Volatile => True); - end Insqhi; - - ------------ - -- Remqhi -- - ------------ - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x93" & LF & HT & - "mb" & LF & HT & - "bis $31, $1, %1", - Outputs => (Remq_Status'Asm_Output ("=v", Status), - Address'Asm_Output ("=r", Item)), - Inputs => Address'Asm_Input ("rJ", Header), - Clobber => "$1, $16", - Volatile => True); - end Remqhi; - - ------------ - -- Insqti -- - ------------ - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %1, $17" & LF & HT & - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x88" & LF & HT & - "mb", - Outputs => Insq_Status'Asm_Output ("=v", Status), - Inputs => (Address'Asm_Input ("rJ", Item), - Address'Asm_Input ("rJ", Header)), - Clobber => "$16, $17", - Volatile => True); - end Insqti; - - ------------ - -- Remqti -- - ------------ - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x94" & LF & HT & - "mb" & LF & HT & - "bis $31, $1, %1", - Outputs => (Remq_Status'Asm_Output ("=v", Status), - Address'Asm_Output ("=r", Item)), - Inputs => Address'Asm_Input ("rJ", Header), - Clobber => "$1, $16", - Volatile => True); - end Remqti; - -end System.Aux_DEC; diff --git a/main/gcc/ada/s-auxdec-vms-ia64.adb b/main/gcc/ada/s-auxdec-vms-ia64.adb deleted file mode 100644 index b8ca67e85b2..00000000000 --- a/main/gcc/ada/s-auxdec-vms-ia64.adb +++ /dev/null @@ -1,576 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Itanium/VMS version. - --- The Add,Clear_Interlocked subprograms are dubiously implmented due to --- the lack of a single bit sync_lock_test_and_set builtin. - --- The "Retry" parameter is ignored due to the lack of retry builtins making --- the subprograms identical to the non-retry versions. - -pragma Style_Checks (All_Checks); --- Turn off alpha ordering check on subprograms, this unit is laid --- out to correspond to the declarations in the DEC 83 System unit. - -with Interfaces; -package body System.Aux_DEC is - - use type Interfaces.Unsigned_8; - - ------------------------ - -- Fetch_From_Address -- - ------------------------ - - function Fetch_From_Address (A : Address) return Target is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - return Ptr.all; - end Fetch_From_Address; - - ----------------------- - -- Assign_To_Address -- - ----------------------- - - procedure Assign_To_Address (A : Address; T : Target) is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - Ptr.all := T; - end Assign_To_Address; - - ----------------------- - -- Clear_Interlocked -- - ----------------------- - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - Clr_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - - begin - Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0); - Bit := Clr_Bit; - Old_Value := Old_Uns /= 0; - end Clear_Interlocked; - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - Clr_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - - begin - Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0); - Bit := Clr_Bit; - Old_Value := Old_Uns /= 0; - Success_Flag := True; - end Clear_Interlocked; - - --------------------- - -- Set_Interlocked -- - --------------------- - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - Set_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - - begin - Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1); - Bit := Set_Bit; - Old_Value := Old_Uns /= 0; - end Set_Interlocked; - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - Set_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - begin - Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1); - Bit := Set_Bit; - Old_Value := Old_Uns /= 0; - Success_Flag := True; - end Set_Interlocked; - - --------------------- - -- Add_Interlocked -- - --------------------- - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer) - is - Overflowed : Boolean := False; - Former : Aligned_Word; - - function Sync_Fetch_And_Add - (Ptr : Address; - Value : Short_Integer) return Short_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2"); - - begin - Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend); - - if Augend.Value < 0 then - Sign := -1; - elsif Augend.Value > 0 then - Sign := 1; - else - Sign := 0; - end if; - - if Former.Value > 0 and then Augend.Value <= 0 then - Overflowed := True; - end if; - - if Overflowed then - raise Constraint_Error; - end if; - end Add_Interlocked; - - ---------------- - -- Add_Atomic -- - ---------------- - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer) - is - procedure Sync_Add_And_Fetch - (Ptr : Address; - Value : Integer); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - begin - Sync_Add_And_Fetch (To.Value'Address, Amount); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Add - (Ptr : Address; - Value : Integer) return Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4"); - - begin - Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount); - Success_Flag := True; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer) - is - procedure Sync_Add_And_Fetch - (Ptr : Address; - Value : Long_Integer); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8"); - begin - Sync_Add_And_Fetch (To.Value'Address, Amount); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Add - (Ptr : Address; - Value : Long_Integer) return Long_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8"); - -- Why do we keep importing this over and over again??? - - begin - Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount); - Success_Flag := True; - end Add_Atomic; - - ---------------- - -- And_Atomic -- - ---------------- - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - procedure Sync_And_And_Fetch - (Ptr : Address; - Value : Integer); - pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4"); - begin - Sync_And_And_Fetch (To.Value'Address, From); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_And - (Ptr : Address; - Value : Integer) return Integer; - pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4"); - - begin - Old_Value := Sync_Fetch_And_And (To.Value'Address, From); - Success_Flag := True; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - procedure Sync_And_And_Fetch - (Ptr : Address; - Value : Long_Integer); - pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8"); - begin - Sync_And_And_Fetch (To.Value'Address, From); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_And - (Ptr : Address; - Value : Long_Integer) return Long_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8"); - - begin - Old_Value := Sync_Fetch_And_And (To.Value'Address, From); - Success_Flag := True; - end And_Atomic; - - --------------- - -- Or_Atomic -- - --------------- - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - procedure Sync_Or_And_Fetch - (Ptr : Address; - Value : Integer); - pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4"); - - begin - Sync_Or_And_Fetch (To.Value'Address, From); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Or - (Ptr : Address; - Value : Integer) return Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4"); - - begin - Old_Value := Sync_Fetch_And_Or (To.Value'Address, From); - Success_Flag := True; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - procedure Sync_Or_And_Fetch - (Ptr : Address; - Value : Long_Integer); - pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8"); - begin - Sync_Or_And_Fetch (To.Value'Address, From); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Or - (Ptr : Address; - Value : Long_Integer) return Long_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8"); - - begin - Old_Value := Sync_Fetch_And_Or (To.Value'Address, From); - Success_Flag := True; - end Or_Atomic; - - ------------ - -- Insqhi -- - ------------ - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status) is - - procedure SYS_PAL_INSQHIL - (STATUS : out Integer; Header : Address; ITEM : Address); - pragma Import (External, SYS_PAL_INSQHIL); - pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL", - (Integer, Address, Address), - (Value, Value, Value)); - - Istat : Integer; - - begin - SYS_PAL_INSQHIL (Istat, Header, Item); - - if Istat = 0 then - Status := OK_Not_First; - elsif Istat = 1 then - Status := OK_First; - - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - end Insqhi; - - ------------ - -- Remqhi -- - ------------ - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - -- The removed item is returned in the second function return register, - -- R9 on IVMS. The VMS ABI calls for "small" records to be returned in - -- these registers, so inventing this odd looking record type makes that - -- all work. - - type Remq is record - Status : Long_Integer; - Item : Address; - end record; - - procedure SYS_PAL_REMQHIL - (Remret : out Remq; Header : Address); - pragma Import (External, SYS_PAL_REMQHIL); - pragma Import_Valued_Procedure - (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL", - (Remq, Address), - (Value, Value)); - - -- Following variables need documentation??? - - Rstat : Long_Integer; - Remret : Remq; - - begin - SYS_PAL_REMQHIL (Remret, Header); - - Rstat := Remret.Status; - Item := Remret.Item; - - if Rstat = 0 then - Status := Fail_Was_Empty; - - elsif Rstat = 1 then - Status := OK_Not_Empty; - - elsif Rstat = 2 then - Status := OK_Empty; - - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - - end Remqhi; - - ------------ - -- Insqti -- - ------------ - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status) is - - procedure SYS_PAL_INSQTIL - (STATUS : out Integer; Header : Address; ITEM : Address); - pragma Import (External, SYS_PAL_INSQTIL); - pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL", - (Integer, Address, Address), - (Value, Value, Value)); - - Istat : Integer; - - begin - SYS_PAL_INSQTIL (Istat, Header, Item); - - if Istat = 0 then - Status := OK_Not_First; - - elsif Istat = 1 then - Status := OK_First; - - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - end Insqti; - - ------------ - -- Remqti -- - ------------ - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - -- The removed item is returned in the second function return register, - -- R9 on IVMS. The VMS ABI calls for "small" records to be returned in - -- these registers, so inventing (where is rest of this comment???) - - type Remq is record - Status : Long_Integer; - Item : Address; - end record; - - procedure SYS_PAL_REMQTIL - (Remret : out Remq; Header : Address); - pragma Import (External, SYS_PAL_REMQTIL); - pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL", - (Remq, Address), - (Value, Value)); - - Rstat : Long_Integer; - Remret : Remq; - - begin - SYS_PAL_REMQTIL (Remret, Header); - - Rstat := Remret.Status; - Item := Remret.Item; - - -- Wouldn't case be nicer here, and in previous similar cases ??? - - if Rstat = 0 then - Status := Fail_Was_Empty; - - elsif Rstat = 1 then - Status := OK_Not_Empty; - - elsif Rstat = 2 then - Status := OK_Empty; - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - end Remqti; - -end System.Aux_DEC; diff --git a/main/gcc/ada/s-auxdec-vms_64.ads b/main/gcc/ada/s-auxdec-vms_64.ads deleted file mode 100644 index 1bac3fbac95..00000000000 --- a/main/gcc/ada/s-auxdec-vms_64.ads +++ /dev/null @@ -1,693 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains definitions that are designed to be compatible --- with the extra definitions in package System for DEC Ada implementations. - --- These definitions can be used directly by withing this package, or merged --- with System using pragma Extend_System (Aux_DEC) - --- This is the VMS 64 bit version - -with Ada.Unchecked_Conversion; - -package System.Aux_DEC is - pragma Preelaborate; - - type Short_Integer_Address is - range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; - -- Integer literals cannot appear naked in an address context, as a - -- result the bounds of Short_Address cannot be given simply as 2^32 etc. - - subtype Short_Address is Address - range Address (Short_Integer_Address'First) .. - Address (Short_Integer_Address'Last); - for Short_Address'Object_Size use 32; - -- This subtype allows addresses to be converted from 64 bits to 32 bits - -- with an appropriate range check. Note that since this is a subtype of - -- type System.Address, the same limitations apply to this subtype. Namely - -- there are no visible arithmetic operations, and integer literals are - -- not available. - - Short_Memory_Size : constant := 2 ** 32; - -- Defined for convenience of porting - - type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; - for Integer_8'Size use 8; - - type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1; - for Integer_16'Size use 16; - - type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; - for Integer_32'Size use 32; - - type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1; - for Integer_64'Size use 64; - - type Integer_8_Array is array (Integer range <>) of Integer_8; - type Integer_16_Array is array (Integer range <>) of Integer_16; - type Integer_32_Array is array (Integer range <>) of Integer_32; - type Integer_64_Array is array (Integer range <>) of Integer_64; - -- These array types are not in all versions of DEC System, and in fact it - -- is not quite clear why they are in some and not others, but since they - -- definitely appear in some versions, we include them unconditionally. - - type Largest_Integer is range Min_Int .. Max_Int; - - type AST_Handler is private; - - No_AST_Handler : constant AST_Handler; - - type Type_Class is - (Type_Class_Enumeration, - Type_Class_Integer, - Type_Class_Fixed_Point, - Type_Class_Floating_Point, - Type_Class_Array, - Type_Class_Record, - Type_Class_Access, - Type_Class_Task, -- also in Ada 95 protected - Type_Class_Address); - - function "not" (Left : Largest_Integer) return Largest_Integer; - function "and" (Left, Right : Largest_Integer) return Largest_Integer; - function "or" (Left, Right : Largest_Integer) return Largest_Integer; - function "xor" (Left, Right : Largest_Integer) return Largest_Integer; - - Address_Zero : constant Address; - No_Addr : constant Address; - Address_Size : constant := Standard'Address_Size; - Short_Address_Size : constant := 32; - - function "+" (Left : Address; Right : Integer) return Address; - function "+" (Left : Integer; Right : Address) return Address; - function "-" (Left : Address; Right : Address) return Integer; - function "-" (Left : Address; Right : Integer) return Address; - - pragma Import (Intrinsic, "+"); - pragma Import (Intrinsic, "-"); - - generic - type Target is private; - function Fetch_From_Address (A : Address) return Target; - - generic - type Target is private; - procedure Assign_To_Address (A : Address; T : Target); - - -- Floating point type declarations for VAX floating point data types - - pragma Warnings (Off); - -- ??? needs comment - - type F_Float is digits 6; - pragma Float_Representation (VAX_Float, F_Float); - - type D_Float is digits 9; - pragma Float_Representation (Vax_Float, D_Float); - - type G_Float is digits 15; - pragma Float_Representation (Vax_Float, G_Float); - - -- Floating point type declarations for IEEE floating point data types - - type IEEE_Single_Float is digits 6; - pragma Float_Representation (IEEE_Float, IEEE_Single_Float); - - type IEEE_Double_Float is digits 15; - pragma Float_Representation (IEEE_Float, IEEE_Double_Float); - - pragma Warnings (On); - - Non_Ada_Error : exception; - - -- Hardware-oriented types and functions - - type Bit_Array is array (Integer range <>) of Boolean; - pragma Pack (Bit_Array); - - subtype Bit_Array_8 is Bit_Array (0 .. 7); - subtype Bit_Array_16 is Bit_Array (0 .. 15); - subtype Bit_Array_32 is Bit_Array (0 .. 31); - subtype Bit_Array_64 is Bit_Array (0 .. 63); - - type Unsigned_Byte is range 0 .. 255; - for Unsigned_Byte'Size use 8; - - function "not" (Left : Unsigned_Byte) return Unsigned_Byte; - function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - - function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte; - function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8; - - type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte; - - type Unsigned_Word is range 0 .. 65535; - for Unsigned_Word'Size use 16; - - function "not" (Left : Unsigned_Word) return Unsigned_Word; - function "and" (Left, Right : Unsigned_Word) return Unsigned_Word; - function "or" (Left, Right : Unsigned_Word) return Unsigned_Word; - function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word; - - function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word; - function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16; - - type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word; - - type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647; - for Unsigned_Longword'Size use 32; - - function "not" (Left : Unsigned_Longword) return Unsigned_Longword; - function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - - function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword; - function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32; - - type Unsigned_Longword_Array is - array (Integer range <>) of Unsigned_Longword; - - type Unsigned_32 is range 0 .. 4_294_967_295; - for Unsigned_32'Size use 32; - - function "not" (Left : Unsigned_32) return Unsigned_32; - function "and" (Left, Right : Unsigned_32) return Unsigned_32; - function "or" (Left, Right : Unsigned_32) return Unsigned_32; - function "xor" (Left, Right : Unsigned_32) return Unsigned_32; - - function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32; - function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32; - - type Unsigned_Quadword is record - L0 : Unsigned_Longword; - L1 : Unsigned_Longword; - end record; - - for Unsigned_Quadword'Size use 64; - for Unsigned_Quadword'Alignment use - Integer'Min (8, Standard'Maximum_Alignment); - - function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword; - function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - - function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword; - function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64; - - type Unsigned_Quadword_Array is - array (Integer range <>) of Unsigned_Quadword; - - function To_Address (X : Integer) return Short_Address; - pragma Pure_Function (To_Address); - - function To_Address_Long (X : Unsigned_Longword) return Short_Address; - pragma Pure_Function (To_Address_Long); - - function To_Integer (X : Short_Address) return Integer; - - function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword; - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; - - -- Conventional names for static subtypes of type UNSIGNED_LONGWORD - - subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1; - subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1; - subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1; - subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1; - subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1; - subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1; - subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1; - subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1; - subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1; - subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1; - subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1; - subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1; - subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1; - subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1; - subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1; - subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1; - subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1; - subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1; - subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1; - subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1; - subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1; - subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1; - subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1; - subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1; - subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1; - subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1; - subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1; - subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1; - subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1; - subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1; - subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1; - - -- Function for obtaining global symbol values - - function Import_Value (Symbol : String) return Unsigned_Longword; - function Import_Address (Symbol : String) return Address; - function Import_Largest_Value (Symbol : String) return Largest_Integer; - - pragma Import (Intrinsic, Import_Value); - pragma Import (Intrinsic, Import_Address); - pragma Import (Intrinsic, Import_Largest_Value); - - -- For the following declarations, note that the declaration without a - -- Retry_Count parameter means to retry infinitely. A value of zero for - -- the Retry_Count parameter means do not retry. - - -- Interlocked-instruction procedures - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean); - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean); - - type Aligned_Word is record - Value : Short_Integer; - end record; - - for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment); - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean); - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean); - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer); - - type Aligned_Integer is record - Value : Integer; - end record; - - for Aligned_Integer'Alignment use - Integer'Min (4, Standard'Maximum_Alignment); - - type Aligned_Long_Integer is record - Value : Long_Integer; - end record; - - for Aligned_Long_Integer'Alignment use - Integer'Min (8, Standard'Maximum_Alignment); - - -- For the following declarations, note that the declaration without a - -- Retry_Count parameter mean to retry infinitely. A value of zero for - -- the Retry_Count means do not retry. - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer); - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer); - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer); - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer); - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer); - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First); - - for Insq_Status use - (Fail_No_Lock => -1, - OK_Not_First => 0, - OK_First => +1); - - type Remq_Status is ( - Fail_No_Lock, - Fail_Was_Empty, - OK_Not_Empty, - OK_Empty); - - for Remq_Status use - (Fail_No_Lock => -1, - Fail_Was_Empty => 0, - OK_Not_Empty => +1, - OK_Empty => +2); - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status); - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status); - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status); - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status); - -private - - Address_Zero : constant Address := Null_Address; - No_Addr : constant Address := Null_Address; - - -- An AST_Handler value is from a typing point of view simply a pointer - -- to a procedure taking a single 64 bit parameter. However, this - -- is a bit misleading, because the data that this pointer references is - -- highly stylized. See body of System.AST_Handling for full details. - - type AST_Handler is access procedure (Param : Long_Integer); - No_AST_Handler : constant AST_Handler := null; - - -- Other operators have incorrect profiles. It would be nice to make - -- them intrinsic, since the backend can handle them, but the front - -- end is not prepared to deal with them, so at least inline them. - - pragma Import (Intrinsic, "not"); - pragma Import (Intrinsic, "and"); - pragma Import (Intrinsic, "or"); - pragma Import (Intrinsic, "xor"); - - -- Other inlined subprograms - - pragma Inline_Always (Fetch_From_Address); - pragma Inline_Always (Assign_To_Address); - - -- Synchronization related subprograms. Mechanism is explicitly set - -- so that the critical parameters are passed by reference. - -- Without this, the parameters are passed by copy, creating load/store - -- race conditions. We also inline them, since this seems more in the - -- spirit of the original (hardware intrinsic) routines. - - pragma Export_Procedure - (Clear_Interlocked, - External => "system__aux_dec__clear_interlocked__1", - Parameter_Types => (Boolean, Boolean), - Mechanism => (Reference, Reference)); - pragma Export_Procedure - (Clear_Interlocked, - External => "system__aux_dec__clear_interlocked__2", - Parameter_Types => (Boolean, Boolean, Natural, Boolean), - Mechanism => (Reference, Reference, Value, Reference)); - pragma Inline_Always (Clear_Interlocked); - - pragma Export_Procedure - (Set_Interlocked, - External => "system__aux_dec__set_interlocked__1", - Parameter_Types => (Boolean, Boolean), - Mechanism => (Reference, Reference)); - pragma Export_Procedure - (Set_Interlocked, - External => "system__aux_dec__set_interlocked__2", - Parameter_Types => (Boolean, Boolean, Natural, Boolean), - Mechanism => (Reference, Reference, Value, Reference)); - pragma Inline_Always (Set_Interlocked); - - pragma Export_Procedure - (Add_Interlocked, - External => "system__aux_dec__add_interlocked__1", - Mechanism => (Value, Reference, Reference)); - pragma Inline_Always (Add_Interlocked); - - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (Add_Atomic); - - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (And_Atomic); - - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (Or_Atomic); - - -- Inline the VAX Queue Functions - - pragma Inline_Always (Insqhi); - pragma Inline_Always (Remqhi); - pragma Inline_Always (Insqti); - pragma Inline_Always (Remqti); - - -- Provide proper unchecked conversion definitions for transfer - -- functions. Note that we need this level of indirection because - -- the formal parameter name is X and not Source (and this is indeed - -- detectable by a program) - - function To_Unsigned_Byte_A is new - Ada.Unchecked_Conversion (Bit_Array_8, Unsigned_Byte); - - function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte - renames To_Unsigned_Byte_A; - - function To_Bit_Array_8_A is new - Ada.Unchecked_Conversion (Unsigned_Byte, Bit_Array_8); - - function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8 - renames To_Bit_Array_8_A; - - function To_Unsigned_Word_A is new - Ada.Unchecked_Conversion (Bit_Array_16, Unsigned_Word); - - function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word - renames To_Unsigned_Word_A; - - function To_Bit_Array_16_A is new - Ada.Unchecked_Conversion (Unsigned_Word, Bit_Array_16); - - function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16 - renames To_Bit_Array_16_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_Longword); - - function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - function To_Bit_Array_32_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Bit_Array_32); - - function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32 - renames To_Bit_Array_32_A; - - function To_Unsigned_32_A is new - Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_32); - - function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32 - renames To_Unsigned_32_A; - - function To_Bit_Array_32_A is new - Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_32); - - function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32 - renames To_Bit_Array_32_A; - - function To_Unsigned_Quadword_A is new - Ada.Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword); - - function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword - renames To_Unsigned_Quadword_A; - - function To_Bit_Array_64_A is new - Ada.Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64); - - function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64 - renames To_Bit_Array_64_A; - - pragma Warnings (Off); - -- Turn warnings off. This is needed for systems with 64-bit integers, - -- where some of these operations are of dubious meaning, but we do not - -- want warnings when we compile on such systems. - - function To_Address_A is new - Ada.Unchecked_Conversion (Integer, Short_Address); - pragma Pure_Function (To_Address_A); - - function To_Address (X : Integer) return Short_Address - renames To_Address_A; - pragma Pure_Function (To_Address); - - function To_Address_Long_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address); - pragma Pure_Function (To_Address_Long_A); - - function To_Address_Long (X : Unsigned_Longword) return Short_Address - renames To_Address_Long_A; - pragma Pure_Function (To_Address_Long); - - function To_Integer_A is new - Ada.Unchecked_Conversion (Short_Address, Integer); - - function To_Integer (X : Short_Address) return Integer - renames To_Integer_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); - - function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (AST_Handler, Unsigned_Longword); - - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - pragma Warnings (On); - -end System.Aux_DEC; diff --git a/main/gcc/ada/s-auxdec.ads b/main/gcc/ada/s-auxdec.ads index 59ba5ec8711..6ce87bd7f91 100644 --- a/main/gcc/ada/s-auxdec.ads +++ b/main/gcc/ada/s-auxdec.ads @@ -39,13 +39,7 @@ package System.Aux_DEC is pragma Preelaborate; subtype Short_Address is Address; - -- In some versions of System.Aux_DEC, notably that for VMS on IA64, there - -- are two address types (64-bit and 32-bit), and the name Short_Address - -- is used for the short address form. To avoid difficulties (in regression - -- tests and elsewhere) with units that reference Short_Address, it is - -- provided for other targets as a synonym for the normal Address type, - -- and, as in the case where the lengths are different, Address and - -- Short_Address can be freely inter-converted. + -- For compatibility with systems having short and long addresses type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; for Integer_8'Size use 8; @@ -109,27 +103,15 @@ package System.Aux_DEC is -- Floating point type declarations for VAX floating point data types - pragma Warnings (Off); - -- ??? needs comment - type F_Float is digits 6; - pragma Float_Representation (VAX_Float, F_Float); - type D_Float is digits 9; - pragma Float_Representation (Vax_Float, D_Float); - type G_Float is digits 15; - pragma Float_Representation (Vax_Float, G_Float); + -- We provide the type names, but these will be IEEE format, not VAX format -- Floating point type declarations for IEEE floating point data types type IEEE_Single_Float is digits 6; - pragma Float_Representation (IEEE_Float, IEEE_Single_Float); - type IEEE_Double_Float is digits 15; - pragma Float_Representation (IEEE_Float, IEEE_Double_Float); - - pragma Warnings (On); Non_Ada_Error : exception; diff --git a/main/gcc/ada/s-boarop.ads b/main/gcc/ada/s-boarop.ads index c321995d295..bc8b4a653b9 100644 --- a/main/gcc/ada/s-boarop.ads +++ b/main/gcc/ada/s-boarop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-carsi8.ads b/main/gcc/ada/s-carsi8.ads index 995cd20792a..c12ff1e5e29 100644 --- a/main/gcc/ada/s-carsi8.ads +++ b/main/gcc/ada/s-carsi8.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-casi16.ads b/main/gcc/ada/s-casi16.ads index e9bfe92d81e..b970b7b5d88 100644 --- a/main/gcc/ada/s-casi16.ads +++ b/main/gcc/ada/s-casi16.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-casi32.ads b/main/gcc/ada/s-casi32.ads index b5af1bc0663..8c3a208d631 100644 --- a/main/gcc/ada/s-casi32.ads +++ b/main/gcc/ada/s-casi32.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-casi64.ads b/main/gcc/ada/s-casi64.ads index e276a56b602..e8a28bdfa09 100644 --- a/main/gcc/ada/s-casi64.ads +++ b/main/gcc/ada/s-casi64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-caun16.ads b/main/gcc/ada/s-caun16.ads index c152dc4cc46..31c0e091d0e 100644 --- a/main/gcc/ada/s-caun16.ads +++ b/main/gcc/ada/s-caun16.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-caun32.ads b/main/gcc/ada/s-caun32.ads index a2f9b562643..61ff4217542 100644 --- a/main/gcc/ada/s-caun32.ads +++ b/main/gcc/ada/s-caun32.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-caun64.ads b/main/gcc/ada/s-caun64.ads index fe0d0e819c6..c2255168fc9 100644 --- a/main/gcc/ada/s-caun64.ads +++ b/main/gcc/ada/s-caun64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-crtl.ads b/main/gcc/ada/s-crtl.ads index faa7031584f..835bbd9e3ae 100644 --- a/main/gcc/ada/s-crtl.ads +++ b/main/gcc/ada/s-crtl.ads @@ -62,6 +62,8 @@ package System.CRTL is type ssize_t is range -(2 ** (Standard'Address_Size - 1)) .. +(2 ** (Standard'Address_Size - 1)) - 1; + type int64 is range -(2 ** 63) .. (2 ** 63) - 1; + type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); pragma Convention (C, Filename_Encoding); @@ -115,8 +117,7 @@ package System.CRTL is function fopen (filename : chars; mode : chars; - encoding : Filename_Encoding := Unspecified; - vms_form : chars := System.Null_Address) return FILEs; + encoding : Filename_Encoding := Unspecified) return FILEs; pragma Import (C, fopen, "__gnat_fopen"); function fputc (C : int; stream : FILEs) return int; @@ -135,8 +136,7 @@ package System.CRTL is (filename : chars; mode : chars; stream : FILEs; - encoding : Filename_Encoding := Unspecified; - vms_form : chars := System.Null_Address) return FILEs; + encoding : Filename_Encoding := Unspecified) return FILEs; pragma Import (C, freopen, "__gnat_freopen"); function fseek @@ -147,14 +147,14 @@ package System.CRTL is function fseek64 (stream : FILEs; - offset : ssize_t; + offset : int64; origin : int) return int; pragma Import (C, fseek64, "__gnat_fseek64"); function ftell (stream : FILEs) return long; pragma Import (C, ftell, "ftell"); - function ftell64 (stream : FILEs) return ssize_t; + function ftell64 (stream : FILEs) return int64; pragma Import (C, ftell64, "__gnat_ftell64"); function getenv (S : String) return System.Address; @@ -222,7 +222,7 @@ package System.CRTL is pragma Import (C, unlink, "__gnat_unlink"); function open (filename : chars; oflag : int) return int; - pragma Import (C, open, "open"); + pragma Import (C, open, "__gnat_open"); function close (fd : int) return int; pragma Import (C, close, "close"); diff --git a/main/gcc/ada/s-direio.adb b/main/gcc/ada/s-direio.adb index 99f8ddf7722..e4ccf364064 100644 --- a/main/gcc/ada/s-direio.adb +++ b/main/gcc/ada/s-direio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ package body System.Direct_IO is subtype AP is FCB.AFCB_Ptr; use type FCB.Shared_Status_Type; - use type System.CRTL.long; + use type System.CRTL.int64; use type System.CRTL.size_t; ----------------------- @@ -280,18 +280,11 @@ package body System.Direct_IO is ------------------ procedure Set_Position (File : File_Type) is - use type System.CRTL.ssize_t; R : int; begin - if Standard'Address_Size = 64 then - R := fseek64 - (File.Stream, ssize_t (File.Bytes) * - ssize_t (File.Index - 1), SEEK_SET); - else - R := fseek - (File.Stream, long (File.Bytes) * - long (File.Index - 1), SEEK_SET); - end if; + R := + fseek64 + (File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET); if R /= 0 then raise Use_Error; @@ -303,20 +296,23 @@ package body System.Direct_IO is ---------- function Size (File : File_Type) return Count is - use type System.CRTL.ssize_t; + Pos : int64; + begin FIO.Check_File_Open (AP (File)); File.Last_Op := Op_Other; - if fseek (File.Stream, 0, SEEK_END) /= 0 then + if fseek64 (File.Stream, 0, SEEK_END) /= 0 then raise Device_Error; end if; - if Standard'Address_Size = 64 then - return Count (ftell64 (File.Stream) / ssize_t (File.Bytes)); - else - return Count (ftell (File.Stream) / long (File.Bytes)); + Pos := ftell64 (File.Stream); + + if Pos = -1 then + raise Use_Error; end if; + + return Count (Pos / int64 (File.Bytes)); end Size; ----------- diff --git a/main/gcc/ada/s-direio.ads b/main/gcc/ada/s-direio.ads index 35fcef05da9..4a60ee72e8e 100644 --- a/main/gcc/ada/s-direio.ads +++ b/main/gcc/ada/s-direio.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 @@ package System.Direct_IO is type Operation is (Op_Read, Op_Write, Op_Other); -- Type used to record last operation (to optimize sequential operations) - subtype Count is Interfaces.C_Streams.long; + subtype Count is Interfaces.C_Streams.int64; -- The Count type in each instantiation is derived from this type subtype Positive_Count is Count range 1 .. Count'Last; diff --git a/main/gcc/ada/s-dsaser.ads b/main/gcc/ada/s-dsaser.ads index ff9c1478bfa..c87e3848689 100644 --- a/main/gcc/ada/s-dsaser.ads +++ b/main/gcc/ada/s-dsaser.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2006-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2006-2014, 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- -- diff --git a/main/gcc/ada/s-excmac-gcc.ads b/main/gcc/ada/s-excmac-gcc.ads index 3700993c47f..1a7aba55531 100644 --- a/main/gcc/ada/s-excmac-gcc.ads +++ b/main/gcc/ada/s-excmac-gcc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2013-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -147,8 +147,7 @@ package System.Exceptions.Machine is -- maintain anyway. type GCC_Exception_Access is access all Unwind_Exception; - -- Pointer to a GCC exception. Do not use convention C as on VMS this - -- would imply the use of 32-bits pointers. + -- Pointer to a GCC exception procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); diff --git a/main/gcc/ada/g-exctra.adb b/main/gcc/ada/s-exctra.adb similarity index 80% copy from main/gcc/ada/g-exctra.adb copy to main/gcc/ada/s-exctra.adb index 1ac24cebd56..1a05cc1efd4 100644 --- a/main/gcc/ada/g-exctra.adb +++ b/main/gcc/ada/s-exctra.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T . E X C E P T I O N _ T R A C E S -- +-- S Y S T E M . E X C E P T I O N _ T R A C E S -- -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2010, AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -29,20 +29,22 @@ -- -- ------------------------------------------------------------------------------ +with Ada.Unchecked_Conversion; + with System.Standard_Library; use System.Standard_Library; with System.Soft_Links; use System.Soft_Links; -package body GNAT.Exception_Traces is +package body System.Exception_Traces is -- Calling the decorator directly from where it is needed would require -- introducing nasty dependencies upon the spec of this package (typically -- in a-except.adb). We also have to deal with the fact that the traceback - -- array within an exception occurrence and the one the decorator shall - -- accept are of different types. These are two reasons for which a wrapper - -- with a System.Address argument is indeed used to call the decorator - -- provided by the user of this package. This wrapper is called via a - -- soft-link, which either is null when no decorator is in place or "points - -- to" the following function otherwise. + -- array within an exception occurrence and the one the decorator accepts + -- are of different types. These are two reasons for which a wrapper with + -- a System.Address argument is indeed used to call the decorator provided + -- by the user of this package. This wrapper is called via a soft-link, + -- which either is null when no decorator is in place or "points to" the + -- following function otherwise. function Decorator_Wrapper (Traceback : System.Address; @@ -67,16 +69,19 @@ package body GNAT.Exception_Traces is (Traceback : System.Address; Len : Natural) return String is - Decorator_Traceback : Tracebacks_Array (1 .. Len); - for Decorator_Traceback'Address use Traceback; + -- Note: do not use an address clause, which is not supported under .NET + + subtype Trace_Array is Traceback_Entries.Tracebacks_Array (1 .. Len); + type Trace_Array_Access is access all Trace_Array; - -- Handle the "transition" from the array stored in the exception - -- occurrence to the array expected by the decorator. + function To_Trace_Array is new + Ada.Unchecked_Conversion (Address, Trace_Array_Access); - pragma Import (Ada, Decorator_Traceback); + Decorator_Traceback : constant Trace_Array_Access := + To_Trace_Array (Traceback); begin - return Current_Decorator.all (Decorator_Traceback); + return Current_Decorator.all (Decorator_Traceback.all); end Decorator_Wrapper; ------------------------- @@ -114,4 +119,4 @@ package body GNAT.Exception_Traces is end case; end Trace_On; -end GNAT.Exception_Traces; +end System.Exception_Traces; diff --git a/main/gcc/ada/g-exctra.ads b/main/gcc/ada/s-exctra.ads similarity index 90% copy from main/gcc/ada/g-exctra.ads copy to main/gcc/ada/s-exctra.ads index 83bc339b481..956f531284c 100644 --- a/main/gcc/ada/g-exctra.ads +++ b/main/gcc/ada/s-exctra.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T . E X C E P T I O N _ T R A C E S -- +-- S Y S T E M . E X C E P T I O N _ T R A C E S -- -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2010, AdaCore -- +-- Copyright (C) 2000-2014, 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- -- @@ -31,7 +31,7 @@ -- This package provides an interface allowing to control *automatic* output -- to standard error upon exception occurrences (as opposed to explicit --- generation of traceback information using GNAT.Traceback). +-- generation of traceback information using System.Traceback). -- This output includes the basic information associated with the exception -- (name, message) as well as a backtrace of the call chain at the point @@ -41,16 +41,16 @@ -- The default backtrace is in the form of absolute code locations which may -- be converted to corresponding source locations using the addr2line utility --- or from within GDB. Please refer to GNAT.Traceback for information about +-- or from within GDB. Please refer to System.Traceback for information about -- what is necessary to be able to exploit this possibility. -- The backtrace output can also be customized by way of a "decorator" which -- may return any string output in association with a provided call chain. -- The decorator replaces the default backtrace mentioned above. -with GNAT.Traceback; use GNAT.Traceback; +with System.Traceback_Entries; -package GNAT.Exception_Traces is +package System.Exception_Traces is -- The following defines the exact situations in which raises will -- cause automatic output of trace information. @@ -80,7 +80,7 @@ package GNAT.Exception_Traces is -- The following provide the backtrace decorating facilities type Traceback_Decorator is access - function (Traceback : Tracebacks_Array) return String; + function (Traceback : Traceback_Entries.Tracebacks_Array) return String; -- A backtrace decorator is a function which returns the string to be -- output for a call chain provided by way of a tracebacks array. @@ -89,8 +89,8 @@ package GNAT.Exception_Traces is -- the default behavior (output of raw addresses) if the provided -- access value is null. -- - -- Note: GNAT.Traceback.Symbolic.Symbolic_Traceback may be used as the + -- Note: System.Traceback.Symbolic.Symbolic_Traceback may be used as the -- Decorator, to get a symbolic traceback. This will cause a significant -- cpu and memory overhead. -end GNAT.Exception_Traces; +end System.Exception_Traces; diff --git a/main/gcc/ada/s-exnint.adb b/main/gcc/ada/s-exnint.adb index bce8fd61c52..5b4f9673c0c 100644 --- a/main/gcc/ada/s-exnint.adb +++ b/main/gcc/ada/s-exnint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-exnint.ads b/main/gcc/ada/s-exnint.ads index fde7af65a5e..79773e825e4 100644 --- a/main/gcc/ada/s-exnint.ads +++ b/main/gcc/ada/s-exnint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-exnlli.adb b/main/gcc/ada/s-exnlli.adb index f060ee3b037..e89c12bac4a 100644 --- a/main/gcc/ada/s-exnlli.adb +++ b/main/gcc/ada/s-exnlli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-exnlli.ads b/main/gcc/ada/s-exnlli.ads index 5713bbc92d8..0c733f869f4 100644 --- a/main/gcc/ada/s-exnlli.ads +++ b/main/gcc/ada/s-exnlli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-expint.adb b/main/gcc/ada/s-expint.adb index 58b82eb9734..0e9070514df 100644 --- a/main/gcc/ada/s-expint.adb +++ b/main/gcc/ada/s-expint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-expint.ads b/main/gcc/ada/s-expint.ads index d0d1cf852a6..6b416702589 100644 --- a/main/gcc/ada/s-expint.ads +++ b/main/gcc/ada/s-expint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-explli.adb b/main/gcc/ada/s-explli.adb index b19aaf5bfbb..32aae1aa971 100644 --- a/main/gcc/ada/s-explli.adb +++ b/main/gcc/ada/s-explli.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-explli.ads b/main/gcc/ada/s-explli.ads index d9d8a132061..9c4f292afe5 100644 --- a/main/gcc/ada/s-explli.ads +++ b/main/gcc/ada/s-explli.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-expllu.adb b/main/gcc/ada/s-expllu.adb index 23ca437e5c6..47192b9b0a8 100644 --- a/main/gcc/ada/s-expllu.adb +++ b/main/gcc/ada/s-expllu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-expuns.adb b/main/gcc/ada/s-expuns.adb index 4bda9509be8..47581b0dbf0 100644 --- a/main/gcc/ada/s-expuns.adb +++ b/main/gcc/ada/s-expuns.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-fatgen.adb b/main/gcc/ada/s-fatgen.adb index 2644e675bd6..b5cd9f56266 100644 --- a/main/gcc/ada/s-fatgen.adb +++ b/main/gcc/ada/s-fatgen.adb @@ -401,22 +401,42 @@ package body System.Fat_Gen is -- Pred -- ---------- - -- Subtract from the given number a number equivalent to the value of its - -- least significant bit. Given that the most significant bit represents - -- a value of 1.0 * radix ** (exp - 1), the value we want is obtained by - -- shifting this by (mantissa-1) bits to the right, i.e. decreasing the - -- exponent by that amount. - - -- Zero has to be treated specially, since its exponent is zero - function Pred (X : T) return T is X_Frac : T; X_Exp : UI; begin + -- Zero has to be treated specially, since its exponent is zero + if X = 0.0 then return -Succ (X); + -- Special treatment for most negative number + + elsif X = T'First then + + -- If not generating infinities, we raise a constraint error + + if T'Machine_Overflows then + raise Constraint_Error with "Pred of largest negative number"; + + -- Otherwise generate a negative infinity + + else + return X / (X - X); + end if; + + -- For infinities, return unchanged + + elsif X < T'First or else X > T'Last then + return X; + + -- Subtract from the given number a number equivalent to the value + -- of its least significant bit. Given that the most significant bit + -- represents a value of 1.0 * radix ** (exp - 1), the value we want + -- is obtained by shifting this by (mantissa-1) bits to the right, + -- i.e. decreasing the exponent by that amount. + else Decompose (X, X_Frac, X_Exp); @@ -624,17 +644,14 @@ package body System.Fat_Gen is -- Succ -- ---------- - -- Similar computation to that of Pred: find value of least significant - -- bit of given number, and add. Zero has to be treated specially since - -- the exponent can be zero, and also we want the smallest denormal if - -- denormals are supported. - function Succ (X : T) return T is X_Frac : T; X_Exp : UI; X1, X2 : T; begin + -- Treat zero specially since it has a zero exponent + if X = 0.0 then X1 := 2.0 ** T'Machine_Emin; @@ -648,6 +665,32 @@ package body System.Fat_Gen is return X1; + -- Special treatment for largest positive number + + elsif X = T'Last then + + -- If not generating infinities, we raise a constraint error + + if T'Machine_Overflows then + raise Constraint_Error with "Succ of largest negative number"; + + -- Otherwise generate a positive infinity + + else + return X / (X - X); + end if; + + -- For infinities, return unchanged + + elsif X < T'First or else X > T'Last then + return X; + + -- Add to the given number a number equivalent to the value + -- of its least significant bit. Given that the most significant bit + -- represents a value of 1.0 * radix ** (exp - 1), the value we want + -- is obtained by shifting this by (mantissa-1) bits to the right, + -- i.e. decreasing the exponent by that amount. + else Decompose (X, X_Frac, X_Exp); @@ -756,12 +799,7 @@ package body System.Fat_Gen is -- Valid -- ----------- - -- Note: this routine does not work for VAX float. We compensate for this - -- in Exp_Attr by using the Valid functions in Vax_Float_Operations rather - -- than the corresponding instantiation of this function. - function Valid (X : not null access T) return Boolean is - IEEE_Emin : constant Integer := T'Machine_Emin - 1; IEEE_Emax : constant Integer := T'Machine_Emax - 1; @@ -823,8 +861,7 @@ package body System.Fat_Gen is Most_Significant_Word : constant Rep_Index := Rep_Last * Standard'Default_Bit_Order; -- Finding the location of the Exponent_Word is a bit tricky. In general - -- we assume Word_Order = Bit_Order. This expression needs to be refined - -- for VMS. + -- we assume Word_Order = Bit_Order. Exponent_Factor : constant Float_Word := 2**(Float_Word'Size - 1) / @@ -855,7 +892,7 @@ package body System.Fat_Gen is for R'Address use XA; -- R is a view of the input floating-point parameter. Note that we -- must avoid copying the actual bits of this parameter in float - -- form (since it may be a signalling NaN. + -- form (since it may be a signalling NaN). E : constant IEEE_Exponent_Range := Integer ((R (Most_Significant_Word) and Exponent_Mask) / @@ -891,30 +928,4 @@ package body System.Fat_Gen is ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0); end Valid; - --------------------- - -- Unaligned_Valid -- - --------------------- - - function Unaligned_Valid (A : System.Address) return Boolean is - subtype FS is String (1 .. T'Size / Character'Size); - type FSP is access FS; - - function To_FSP is new Ada.Unchecked_Conversion (Address, FSP); - - Local_T : aliased T; - - begin - -- Note that we have to be sure that we do not load the value into a - -- floating-point register, since a signalling NaN may cause a trap. - -- The following assignment is what does the actual alignment, since - -- we know that the target Local_T is aligned. - - To_FSP (Local_T'Address).all := To_FSP (A).all; - - -- Now that we have an aligned value, we can use the normal aligned - -- version of Valid to obtain the required result. - - return Valid (Local_T'Access); - end Unaligned_Valid; - end System.Fat_Gen; diff --git a/main/gcc/ada/s-fatgen.ads b/main/gcc/ada/s-fatgen.ads index 13e78850416..d8d761eaaed 100644 --- a/main/gcc/ada/s-fatgen.ads +++ b/main/gcc/ada/s-fatgen.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -94,28 +94,18 @@ package System.Fat_Gen is -- be an abnormal value that cannot be passed in a floating-point -- register, and the whole point of 'Valid is to prevent exceptions. -- Note that the object of type T must have the natural alignment - -- for type T. See Unaligned_Valid for further discussion. - -- - -- Note: this routine does not work for Vax_Float ??? - - function Unaligned_Valid (A : System.Address) return Boolean; - -- This version of Valid is used if the floating-point value to - -- be checked is not known to be aligned (for example it appears - -- in a packed record). In this case, we cannot call Valid since - -- Valid assumes proper full alignment. Instead Unaligned_Valid - -- performs the same processing for a possibly unaligned float, - -- by first doing a copy and then calling Valid. One might think - -- that the front end could simply do a copy to an aligned temp, - -- but remember that we may have an abnormal value that cannot - -- be copied into a floating-point register, so things are a bit - -- trickier than one might expect. - -- - -- Note: Unaligned_Valid is never called for a target which does - -- not require strict alignment (e.g. the ia32/x86), since on a - -- target not requiring strict alignment, it is fine to pass a - -- non-aligned value to the standard Valid routine. - -- - -- Note: this routine does not work for Vax_Float ??? + -- for type T. + + type S is new String (1 .. T'Size / Character'Size); + type P is access all S with Storage_Size => 0; + -- Buffer and access types used to initialize temporaries for validity + -- checks, if the value to be checked has reverse scalar storage order, or + -- is not known to be properly aligned (for example it appears in a packed + -- record). In this case, we cannot call Valid since Valid assumes proper + -- full alignment. Instead, we copy the value to a temporary location using + -- type S (we cannot simply do a copy of a T value, because the value might + -- be invalid, in which case it might not be possible to copy it through a + -- floating point register). private pragma Inline (Machine); diff --git a/main/gcc/ada/s-fileio.adb b/main/gcc/ada/s-fileio.adb index 8a9c9c10c53..73838bf8e54 100644 --- a/main/gcc/ada/s-fileio.adb +++ b/main/gcc/ada/s-fileio.adb @@ -29,34 +29,26 @@ -- -- ------------------------------------------------------------------------------ -with Ada.Finalization; use Ada.Finalization; -with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Finalization; use Ada.Finalization; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Unchecked_Deallocation; with Interfaces.C; -with Interfaces.C_Streams; use Interfaces.C_Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.Case_Util; use System.Case_Util; with System.CRTL; - -with System.Case_Util; use System.Case_Util; with System.OS_Lib; with System.Soft_Links; -with Ada.Unchecked_Deallocation; - package body System.File_IO is use System.File_Control_Block; package SSL renames System.Soft_Links; - use type Interfaces.C.int; use type CRTL.size_t; - - subtype String_Access is System.OS_Lib.String_Access; - procedure Free (X : in out String_Access) renames System.OS_Lib.Free; - - function "=" (X, Y : String_Access) return Boolean - renames System.OS_Lib."="; + use type Interfaces.C.int; ---------------------- -- Global Variables -- @@ -104,9 +96,6 @@ package body System.File_IO is (C, text_translation_required, "__gnat_text_translation_required"); -- If true, add appropriate suffix to control string for Open - VMS_Formstr : String_Access := null; - -- For special VMS RMS keywords and values - ----------------------- -- Local Subprograms -- ----------------------- @@ -122,12 +111,12 @@ package body System.File_IO is 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. + -- 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. function Errno_Message (Name : String; @@ -141,14 +130,6 @@ package body System.File_IO is -- Clear error indication on File and raise Device_Error with an exception -- message providing errno information. - procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access); - -- Parse the RMS Keys - - function Form_RMS_Context_Key - (Form : String; - VMS_Form : String_Access) return Natural; - -- Parse the RMS Context Key - ---------------- -- Append_Set -- ---------------- @@ -389,10 +370,6 @@ package body System.File_IO is -- Finalize -- -------------- - -- Note: we do not need to worry about locking against multiple task access - -- in this routine, since it is called only from the environment task just - -- before terminating execution. - procedure Finalize (V : in out File_IO_Clean_Up_Type) is pragma Warnings (Off, V); @@ -400,7 +377,6 @@ package body System.File_IO is Fptr2 : AFCB_Ptr; Discard : int; - pragma Unreferenced (Discard); begin -- Take a lock to protect global Open_Files data structure @@ -637,197 +613,6 @@ package body System.File_IO is Stop := 0; end Form_Parameter; - -------------------------- - -- Form_RMS_Context_Key -- - -------------------------- - - function Form_RMS_Context_Key - (Form : String; - VMS_Form : String_Access) return Natural - is - type Context_Parms is - (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode, - Force_Stream_Mode, Explicit_Write); - -- Ada-fied list of all possible Context keyword values - - Pos : Natural := 0; - Klen : Natural := 0; - Index : Natural; - - begin - -- Find the end of the occupation - - for J in VMS_Form'First .. VMS_Form'Last loop - if VMS_Form (J) = ASCII.NUL then - Pos := J; - exit; - end if; - end loop; - - Index := Form'First; - while Index < Form'Last loop - if Form (Index) = '=' then - Index := Index + 1; - - -- Loop through the context values and look for a match - - for Parm in Context_Parms loop - declare - KImage : String := Context_Parms'Image (Parm); - - begin - Klen := KImage'Length; - To_Lower (KImage); - - if Index + Klen - 1 <= Form'Last - and then Form (Index .. Index + Klen - 1) = KImage - then - case Parm is - when Force_Record_Mode => - VMS_Form (Pos) := '"'; - Pos := Pos + 1; - VMS_Form (Pos .. Pos + 6) := "ctx=rec"; - Pos := Pos + 7; - VMS_Form (Pos) := '"'; - Pos := Pos + 1; - VMS_Form (Pos) := ','; - return Index + Klen; - - when Force_Stream_Mode => - VMS_Form (Pos) := '"'; - Pos := Pos + 1; - VMS_Form (Pos .. Pos + 6) := "ctx=stm"; - Pos := Pos + 7; - VMS_Form (Pos) := '"'; - Pos := Pos + 1; - VMS_Form (Pos) := ','; - return Index + Klen; - - when others => - raise Use_Error - with "unimplemented RMS Context Value"; - end case; - end if; - end; - end loop; - - raise Use_Error with "unrecognized RMS Context Value"; - end if; - end loop; - - raise Use_Error with "malformed RMS Context Value"; - end Form_RMS_Context_Key; - - ----------------------- - -- Form_VMS_RMS_Keys -- - ----------------------- - - procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access) - is - VMS_RMS_Keys_Token : constant String := "vms_rms_keys"; - Klen : Natural := VMS_RMS_Keys_Token'Length; - Index : Natural; - - -- Ada-fied list of all RMS keywords, translated from the HP C Run-Time - -- Library Reference Manual, Table REF-3: RMS Valid Keywords and Values. - - type RMS_Keys is - (Access_Callback, Allocation_Quantity, Block_Size, Context, - Default_Extension_Quantity, Default_File_Name_String, Error_Callback, - File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count, - Multiblock_Count, Multibuffer_Count, Maximum_Record_Size, - Terminal_Input_Prompt, Record_Attributes, Record_Format, - Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options, - Timeout_IO_Value); - - begin - Index := Form'First + Klen - 1; - while Index < Form'Last loop - Index := Index + 1; - - -- Scan for the token signalling VMS RMS Keys ahead. Should - -- whitespace be eaten??? - - if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then - - -- Allocate the VMS form string that will contain the cryptic - -- CRTL RMS strings and initialize it to all nulls. Since the - -- CRTL strings are always shorter than the Ada-fied strings, - -- it follows that an allocation of the original size will be - -- more than adequate. - VMS_Form := new String'(Form (Form'First .. Form'Last)); - VMS_Form.all := (others => ASCII.NUL); - - if Form (Index) = '=' then - Index := Index + 1; - if Form (Index) = '(' then - while Index < Form'Last loop - Index := Index + 1; - - -- Loop through the RMS Keys and dispatch - - for Key in RMS_Keys loop - declare - KImage : String := RMS_Keys'Image (Key); - - begin - Klen := KImage'Length; - To_Lower (KImage); - - if Form (Index .. Index + Klen - 1) = KImage then - case Key is - when Context => - Index := Form_RMS_Context_Key - (Form (Index + Klen .. Form'Last), - VMS_Form); - exit; - - when others => - raise Use_Error - with "unimplemented VMS RMS Form Key"; - end case; - end if; - end; - end loop; - - if Form (Index) = ')' then - - -- Done, erase the unneeded trailing comma and return - - for J in reverse VMS_Form'First .. VMS_Form'Last loop - if VMS_Form (J) = ',' then - VMS_Form (J) := ASCII.NUL; - return; - end if; - end loop; - - -- Shouldn't be possible to get here - - raise Use_Error; - - elsif Form (Index) = ',' then - - -- Another key ahead, exit inner loop - - null; - - else - - -- Keyword value not terminated correctly - - raise Use_Error with "malformed VMS RMS Form"; - end if; - end loop; - end if; - end if; - - -- Found the keyword, but not followed by correct syntax - - raise Use_Error with "malformed VMS RMS Form"; - end if; - end loop; - end Form_VMS_RMS_Keys; - ------------- -- Is_Open -- ------------- @@ -940,6 +725,11 @@ package body System.File_IO is pragma Import (C, Get_Case_Sensitive, "__gnat_get_file_names_case_sensitive"); + procedure Record_AFCB; + -- Create and record new AFCB into the runtime, note that the + -- implementation uses the variables below which corresponds to the + -- status of the opened file. + File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or not case @@ -982,6 +772,36 @@ package body System.File_IO is Encoding : CRTL.Filename_Encoding; -- Filename encoding specified into the form parameter + ----------------- + -- Record_AFCB -- + ----------------- + + procedure Record_AFCB is + begin + File_Ptr := AFCB_Allocate (Dummy_FCB); + + -- Note that we cannot use an aggregate here as File_Ptr is a + -- class-wide access to a limited type (Root_Stream_Type). + + File_Ptr.Is_Regular_File := is_regular_file (fileno (Stream)) /= 0; + File_Ptr.Is_System_File := False; + File_Ptr.Text_Encoding := Text_Encoding; + File_Ptr.Shared_Status := Shared; + File_Ptr.Access_Method := Amethod; + File_Ptr.Stream := Stream; + File_Ptr.Form := new String'(Formstr); + File_Ptr.Name := new String'(Fullname + (1 .. Full_Name_Len)); + File_Ptr.Mode := Mode; + File_Ptr.Is_Temporary_File := Tempfile; + File_Ptr.Encoding := Encoding; + + Chain_File (File_Ptr); + Append_Set (File_Ptr); + end Record_AFCB; + + -- Start of processing for Open + begin if File_Ptr /= null then raise Status_Error with "file already open"; @@ -1076,17 +896,6 @@ package body System.File_IO is end; end if; - -- Acquire settings of target specific form parameters on VMS. Only - -- Context is currently implemented, for forcing a byte stream mode - -- read. On non-VMS systems, the settings are ultimately ignored in - -- the implementation of __gnat_fopen. - - -- Should a warning be issued on non-VMS systems? That's not possible - -- without testing System.OpenVMS boolean which isn't present in most - -- non-VMS versions of package System. - - Form_VMS_RMS_Keys (Formstr, VMS_Formstr); - -- If we were given a stream (call from xxx.C_Streams.Open), then set -- the full name to the given one, and skip to end of processing. @@ -1198,6 +1007,9 @@ package body System.File_IO is and then P.Shared_Status = Yes then Stream := P.Stream; + + Record_AFCB; + exit; -- Otherwise one of the files has Shared=Yes and one has @@ -1224,9 +1036,13 @@ package body System.File_IO is end; end if; - -- Open specified file if we did not find an existing stream + -- Open specified file if we did not find an existing stream, + -- otherwise we just return as there is nothing more to be done. + + if Stream /= NULL_Stream then + return; - if Stream = NULL_Stream then + else Fopen_Mode (Mode, Text_Encoding in Text_Content_Encoding, Creat, Amethod, Fopstr); @@ -1251,19 +1067,8 @@ package body System.File_IO is -- since by the time of the delete, the current working directory -- may have changed and we do not want to delete a different file. - if VMS_Formstr = null then - Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, - Null_Address); - else - Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, - VMS_Formstr.all'Address); - end if; - - -- No need to keep this around - - if VMS_Formstr /= null then - Free (VMS_Formstr); - end if; + Stream := + fopen (Namestr'Address, Fopstr'Address, Encoding); if Stream = NULL_Stream then @@ -1299,22 +1104,7 @@ package body System.File_IO is -- committed to completing the opening of the file. Allocate block on -- heap and fill in its fields. - File_Ptr := AFCB_Allocate (Dummy_FCB); - - File_Ptr.Is_Regular_File := (is_regular_file (fileno (Stream)) /= 0); - File_Ptr.Is_System_File := False; - File_Ptr.Text_Encoding := Text_Encoding; - File_Ptr.Shared_Status := Shared; - File_Ptr.Access_Method := Amethod; - File_Ptr.Stream := Stream; - File_Ptr.Form := new String'(Formstr); - File_Ptr.Name := new String'(Fullname (1 .. Full_Name_Len)); - File_Ptr.Mode := Mode; - File_Ptr.Is_Temporary_File := Tempfile; - File_Ptr.Encoding := Encoding; - - Chain_File (File_Ptr); - Append_Set (File_Ptr); + Record_AFCB; end Open; ------------------------ @@ -1430,21 +1220,9 @@ package body System.File_IO is (Mode, File.Text_Encoding in Text_Content_Encoding, False, File.Access_Method, Fopstr); - Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr); - - if VMS_Formstr = null then - File.Stream := freopen - (File.Name.all'Address, Fopstr'Address, File.Stream, - File.Encoding, Null_Address); - else - File.Stream := freopen - (File.Name.all'Address, Fopstr'Address, File.Stream, - File.Encoding, VMS_Formstr.all'Address); - end if; - - if VMS_Formstr /= null then - Free (VMS_Formstr); - end if; + File.Stream := freopen + (File.Name.all'Address, Fopstr'Address, File.Stream, + File.Encoding); if File.Stream = NULL_Stream then Close (File_Ptr); @@ -1463,9 +1241,9 @@ package body System.File_IO is procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is begin -- Note: for most purposes, the Siz and 1 parameters in the fwrite call - -- could be reversed, but on VMS, this is a better choice, since for - -- some file formats, reversing the parameters results in records of one - -- byte each. + -- could be reversed, but we have encountered systems where this is a + -- better choice, since for some file formats, reversing the parameters + -- results in records of one byte each. SSL.Abort_Defer.all; diff --git a/main/gcc/ada/s-filofl.ads b/main/gcc/ada/s-filofl.ads deleted file mode 100644 index e3aba15d571..00000000000 --- a/main/gcc/ada/s-filofl.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ I E E E _ L O N G _ F L O A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for IEEE long float. This is used on VMS targets where --- we can't just use Long_Float, since this may have been mapped to Vax_Float --- using a Float_Representation configuration pragma. - -with System.Fat_Gen; - -package System.Fat_IEEE_Long_Float is - pragma Pure; - - type Fat_IEEE_Long is digits 15; - pragma Float_Representation (IEEE_Float, Fat_IEEE_Long); - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_IEEE_Long is new System.Fat_Gen (Fat_IEEE_Long); - -end System.Fat_IEEE_Long_Float; diff --git a/main/gcc/ada/s-fishfl.ads b/main/gcc/ada/s-fishfl.ads deleted file mode 100644 index 335b714b644..00000000000 --- a/main/gcc/ada/s-fishfl.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ I E E E _ S H O R T _ F L O A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for IEEE short float. This is used on VMS targets where --- we can't just use Float, since this may have been mapped to Vax_Float --- using a Float_Representation configuration pragma. - -with System.Fat_Gen; - -package System.Fat_IEEE_Short_Float is - pragma Pure; - - type Fat_IEEE_Short is digits 6; - pragma Float_Representation (IEEE_Float, Fat_IEEE_Short); - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_IEEE_Short is new System.Fat_Gen (Fat_IEEE_Short); - -end System.Fat_IEEE_Short_Float; diff --git a/main/gcc/ada/s-fore.adb b/main/gcc/ada/s-fore.adb index 5d5a2836e12..df8cdf2101c 100644 --- a/main/gcc/ada/s-fore.adb +++ b/main/gcc/ada/s-fore.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-fore.ads b/main/gcc/ada/s-fore.ads index e3fee489697..f334d96d47f 100644 --- a/main/gcc/ada/s-fore.ads +++ b/main/gcc/ada/s-fore.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-fvadfl.ads b/main/gcc/ada/s-fvadfl.ads deleted file mode 100644 index a007fdf76a7..00000000000 --- a/main/gcc/ada/s-fvadfl.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ V A X _ D _ F L O A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for VAX D-float for use on VMS targets. - -with System.Fat_Gen; - -package System.Fat_VAX_D_Float is - pragma Pure; - - pragma Warnings (Off); - -- This unit is normally used only for VMS, but we compile it for other - -- targets for the convenience of testing vms code using -gnatdm. - - type Fat_VAX_D is digits 9; - pragma Float_Representation (VAX_Float, Fat_VAX_D); - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_VAX_D_Float is new System.Fat_Gen (Fat_VAX_D); - -end System.Fat_VAX_D_Float; diff --git a/main/gcc/ada/s-fvaffl.ads b/main/gcc/ada/s-fvaffl.ads deleted file mode 100644 index 13dd0c794e5..00000000000 --- a/main/gcc/ada/s-fvaffl.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ V A X _ F _ F L O A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for VAX F-float for use on VMS targets. - -with System.Fat_Gen; - -package System.Fat_VAX_F_Float is - pragma Pure; - - pragma Warnings (Off); - -- This unit is normally used only for VMS, but we compile it for other - -- targets for the convenience of testing vms code using -gnatdm. - - type Fat_VAX_F is digits 6; - pragma Float_Representation (VAX_Float, Fat_VAX_F); - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_VAX_F_Float is new System.Fat_Gen (Fat_VAX_F); - -end System.Fat_VAX_F_Float; diff --git a/main/gcc/ada/s-fvagfl.ads b/main/gcc/ada/s-fvagfl.ads deleted file mode 100644 index 18ce996841e..00000000000 --- a/main/gcc/ada/s-fvagfl.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ V A X _ G _ F L O A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2005,2009 Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for VAX F-float for use on VMS targets. - -with System.Fat_Gen; - -package System.Fat_VAX_G_Float is - pragma Pure; - - pragma Warnings (Off); - -- This unit is normally used only for VMS, but we compile it for other - -- targets for the convenience of testing vms code using -gnatdm. - - type Fat_VAX_G is digits 15; - pragma Float_Representation (VAX_Float, Fat_VAX_G); - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_VAX_G_Float is new System.Fat_Gen (Fat_VAX_G); - -end System.Fat_VAX_G_Float; diff --git a/main/gcc/ada/s-geveop.ads b/main/gcc/ada/s-geveop.ads index 3fa7204b147..3796bc955dc 100644 --- a/main/gcc/ada/s-geveop.ads +++ b/main/gcc/ada/s-geveop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-imgbiu.adb b/main/gcc/ada/s-imgbiu.adb index f7b0f452162..66c76f5d7e6 100644 --- a/main/gcc/ada/s-imgbiu.adb +++ b/main/gcc/ada/s-imgbiu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 @@ package body System.Img_BIU is procedure Set_Digits (T : Unsigned); -- Set digits of absolute value of T + ---------------- + -- Set_Digits -- + ---------------- + procedure Set_Digits (T : Unsigned) is begin if T >= BU then diff --git a/main/gcc/ada/s-imgbiu.ads b/main/gcc/ada/s-imgbiu.ads index 2ddce288675..987b8b08eeb 100644 --- a/main/gcc/ada/s-imgbiu.ads +++ b/main/gcc/ada/s-imgbiu.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-imgllb.adb b/main/gcc/ada/s-imgllb.adb index 2ab1e4d76ad..3f0da252883 100644 --- a/main/gcc/ada/s-imgllb.adb +++ b/main/gcc/ada/s-imgllb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -102,6 +102,10 @@ package body System.Img_LLB 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 >= BU then diff --git a/main/gcc/ada/s-imgllb.ads b/main/gcc/ada/s-imgllb.ads index 1a5636bd075..9c94baa3b6d 100644 --- a/main/gcc/ada/s-imgllb.ads +++ b/main/gcc/ada/s-imgllb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-imgllw.adb b/main/gcc/ada/s-imgllw.adb index c4670d288a3..78d86747a81 100644 --- a/main/gcc/ada/s-imgllw.adb +++ b/main/gcc/ada/s-imgllw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -96,6 +96,10 @@ package body System.Img_LLW 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 diff --git a/main/gcc/ada/s-imgllw.ads b/main/gcc/ada/s-imgllw.ads index e84a8f098b9..baf4a38c377 100644 --- a/main/gcc/ada/s-imgllw.ads +++ b/main/gcc/ada/s-imgllw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-imgrea.adb b/main/gcc/ada/s-imgrea.adb index fcfd107dd03..075a5774000 100644 --- a/main/gcc/ada/s-imgrea.adb +++ b/main/gcc/ada/s-imgrea.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,9 +93,10 @@ package body System.Img_Real is -- output of -0.0 on targets where this is the case). We can of -- course still see a -0.0 on a target where Signed_Zeroes is -- False (since this attribute refers to the proper handling of - -- negative zeroes, not to their existence). + -- negative zeroes, not to their existence). We do not generate + -- a blank for positive infinity, since we output an explicit +. - if not Is_Negative (V) + if (not Is_Negative (V) and then V <= Long_Long_Float'Last) or else (not Long_Long_Float'Signed_Zeros and then V = -0.0) then S (1) := ' '; diff --git a/main/gcc/ada/s-imgwiu.adb b/main/gcc/ada/s-imgwiu.adb index 62dd9c1359d..022f75ccf3f 100644 --- a/main/gcc/ada/s-imgwiu.adb +++ b/main/gcc/ada/s-imgwiu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -94,6 +94,10 @@ package body System.Img_WIU is procedure Set_Digits (T : Unsigned); -- Set digits of absolute value of T + ---------------- + -- Set_Digits -- + ---------------- + procedure Set_Digits (T : Unsigned) is begin if T >= 10 then diff --git a/main/gcc/ada/s-inmaop-vms.adb b/main/gcc/ada/s-inmaop-vms.adb deleted file mode 100644 index b99b155f38c..00000000000 --- a/main/gcc/ada/s-inmaop-vms.adb +++ /dev/null @@ -1,303 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - -with System.OS_Interface; -with System.Aux_DEC; -with System.Parameters; -with System.Tasking; -with System.Tasking.Initialization; -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - -with Ada.Unchecked_Conversion; - -package body System.Interrupt_Management.Operations is - - use System.OS_Interface; - use System.Parameters; - use System.Tasking; - use type unsigned_short; - - function To_Address is - new Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - package POP renames System.Task_Primitives.Operations; - - ---------------------------- - -- Thread_Block_Interrupt -- - ---------------------------- - - procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Thread_Block_Interrupt; - - ------------------------------ - -- Thread_Unblock_Interrupt -- - ------------------------------ - - procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Thread_Unblock_Interrupt; - - ------------------------ - -- Set_Interrupt_Mask -- - ------------------------ - - procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is - pragma Warnings (Off, Mask); - begin - null; - end Set_Interrupt_Mask; - - procedure Set_Interrupt_Mask - (Mask : access Interrupt_Mask; - OMask : access Interrupt_Mask) - is - pragma Warnings (Off, Mask); - pragma Warnings (Off, OMask); - begin - null; - end Set_Interrupt_Mask; - - ------------------------ - -- Get_Interrupt_Mask -- - ------------------------ - - procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is - pragma Warnings (Off, Mask); - begin - null; - end Get_Interrupt_Mask; - - -------------------- - -- Interrupt_Wait -- - -------------------- - - function To_unsigned_long is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long); - - function Interrupt_Wait (Mask : access Interrupt_Mask) - return Interrupt_ID - is - Self_ID : constant Task_Id := Self; - Iosb : IO_Status_Block_Type := (0, 0, 0); - Status : Cond_Value_Type; - - begin - - -- A QIO read is registered. The system call returns immediately - -- after scheduling an AST to be fired when the operation - -- completes. - - Sys_QIO - (Status => Status, - Chan => Rcv_Interrupt_Chan, - Func => IO_READVBLK, - Iosb => Iosb, - Astadr => - POP.DEC.Interrupt_AST_Handler'Access, - Astprm => To_Address (Self_ID), - P1 => To_unsigned_long (Interrupt_Mailbox'Address), - P2 => Interrupt_ID'Size / 8); - - pragma Assert ((Status and 1) = 1); - - loop - - -- Wait to be woken up. Could be that the AST has fired, - -- in which case the Iosb.Status variable will be non-zero, - -- or maybe the wait is being aborted. - - POP.Sleep - (Self_ID, - System.Tasking.Interrupt_Server_Blocked_On_Event_Flag); - - if Iosb.Status /= 0 then - if (Iosb.Status and 1) = 1 - and then Mask (Signal (Interrupt_Mailbox)) - then - return Interrupt_Mailbox; - else - return 0; - end if; - else - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - System.Tasking.Initialization.Defer_Abort (Self_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - end if; - end loop; - end Interrupt_Wait; - - ---------------------------- - -- Install_Default_Action -- - ---------------------------- - - procedure Install_Default_Action (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Install_Default_Action; - - --------------------------- - -- Install_Ignore_Action -- - --------------------------- - - procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Install_Ignore_Action; - - ------------------------- - -- Fill_Interrupt_Mask -- - ------------------------- - - procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - Mask.all := (others => True); - end Fill_Interrupt_Mask; - - -------------------------- - -- Empty_Interrupt_Mask -- - -------------------------- - - procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - Mask.all := (others => False); - end Empty_Interrupt_Mask; - - --------------------------- - -- Add_To_Interrupt_Mask -- - --------------------------- - - procedure Add_To_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - Mask (Signal (Interrupt)) := True; - end Add_To_Interrupt_Mask; - - -------------------------------- - -- Delete_From_Interrupt_Mask -- - -------------------------------- - - procedure Delete_From_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - Mask (Signal (Interrupt)) := False; - end Delete_From_Interrupt_Mask; - - --------------- - -- Is_Member -- - --------------- - - function Is_Member - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) return Boolean - is - begin - return Mask (Signal (Interrupt)); - end Is_Member; - - ------------------------- - -- Copy_Interrupt_Mask -- - ------------------------- - - procedure Copy_Interrupt_Mask - (X : out Interrupt_Mask; - Y : Interrupt_Mask) - is - begin - X := Y; - end Copy_Interrupt_Mask; - - ---------------------------- - -- Interrupt_Self_Process -- - ---------------------------- - - procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is - Status : Cond_Value_Type; - begin - Sys_QIO - (Status => Status, - Chan => Snd_Interrupt_Chan, - Func => IO_WRITEVBLK, - P1 => To_unsigned_long (Interrupt'Address), - P2 => Interrupt_ID'Size / 8); - - -- The following could use a comment ??? - - pragma Assert ((Status and 1) = 1); - end Interrupt_Self_Process; - - -------------------------- - -- Setup_Interrupt_Mask -- - -------------------------- - - procedure Setup_Interrupt_Mask is - begin - null; - end Setup_Interrupt_Mask; - -begin - Interrupt_Management.Initialize; - Environment_Mask := (others => False); - All_Tasks_Mask := (others => True); - - for J in Interrupt_ID loop - if Keep_Unmasked (J) then - Environment_Mask (Signal (J)) := True; - All_Tasks_Mask (Signal (J)) := False; - end if; - end loop; -end System.Interrupt_Management.Operations; diff --git a/main/gcc/ada/s-interr-hwint.adb b/main/gcc/ada/s-interr-hwint.adb index 654efdc3b21..8e2950f30fb 100644 --- a/main/gcc/ada/s-interr-hwint.adb +++ b/main/gcc/ada/s-interr-hwint.adb @@ -31,7 +31,7 @@ -- Invariants: --- All user-handleable signals are masked at all times in all tasks/threads +-- All user-handlable signals are masked at all times in all tasks/threads -- except possibly for the Interrupt_Manager task. -- When a user task wants to have the effect of masking/unmasking an signal, @@ -123,8 +123,11 @@ package body System.Interrupts is end Interrupt_Manager; task type Interrupt_Server_Task - (Interrupt : Interrupt_ID; Int_Sema : Binary_Semaphore_Id) is + (Interrupt : Interrupt_ID; + Int_Sema : Binary_Semaphore_Id) + is -- Server task for vectored hardware interrupt handling + pragma Interrupt_Priority (System.Interrupt_Priority'First + 2); end Interrupt_Server_Task; @@ -152,7 +155,7 @@ package body System.Interrupts is -- is specified through the pragma Attach_Handler. User_Entry : array (Interrupt_ID) of Entry_Assoc := - (others => (T => Null_Task, E => Null_Task_Entry)); + (others => (T => Null_Task, E => Null_Task_Entry)); pragma Volatile_Components (User_Entry); -- Holds the task and entry index (if any) for each interrupt / signal @@ -172,19 +175,18 @@ package body System.Interrupts is Registered_Handler_Tail : R_Link := null; Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id := - (others => System.Tasking.Null_Task); + (others => System.Tasking.Null_Task); pragma Atomic_Components (Server_ID); -- Holds the Task_Id of the Server_Task for each interrupt / signal. -- Task_Id is needed to accomplish locking per interrupt base. Also -- is needed to determine whether to create a new Server_Task. Semaphore_ID_Map : array - (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) - of Binary_Semaphore_Id := (others => 0); + (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) of + Binary_Semaphore_Id := (others => 0); -- Array of binary semaphores associated with vectored interrupts. Note -- that the last bound should be Max_HW_Interrupt, but this will raise - -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes - -- instead. + -- Storage_Error if Num_HW_Interrupts is null so use extra 4 bytes instead. Interrupt_Access_Hold : Interrupt_Task_Access; -- Variable for allocating an Interrupt_Server_Task @@ -719,6 +721,11 @@ package body System.Interrupts is ----------------------- task body Interrupt_Manager is + -- By making this task independent of any master, when the process goes + -- away, the Interrupt_Manager will terminate gracefully. + + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + pragma Unreferenced (Ignore); -------------------- -- Local Routines -- @@ -907,11 +914,6 @@ package body System.Interrupts is -- Start of processing for Interrupt_Manager begin - -- By making this task independent of any master, when the process goes - -- away, the Interrupt_Manager will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - loop -- A block is needed to absorb Program_Error exception @@ -1039,6 +1041,8 @@ package body System.Interrupts is -- Server task for vectored hardware interrupt handling task body Interrupt_Server_Task is + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + Self_Id : constant Task_Id := Self; Tmp_Handler : Parameterless_Handler; Tmp_ID : Task_Id; @@ -1046,12 +1050,11 @@ package body System.Interrupts is Status : int; begin - System.Tasking.Utilities.Make_Independent; Semaphore_ID_Map (Interrupt) := Int_Sema; loop - -- Pend on semaphore that will be triggered by the - -- umbrella handler when the associated interrupt comes in + -- Pend on semaphore that will be triggered by the umbrella handler + -- when the associated interrupt comes in. Status := Binary_Semaphore_Obtain (Int_Sema); pragma Assert (Status = 0); @@ -1073,8 +1076,8 @@ package body System.Interrupts is (Tmp_ID, Tmp_Entry_Index, System.Null_Address); else - -- Semaphore has been flushed by an unbind operation in - -- the Interrupt_Manager. Terminate the server task. + -- Semaphore has been flushed by an unbind operation in the + -- Interrupt_Manager. Terminate the server task. -- Wait for the Interrupt_Manager to complete its work diff --git a/main/gcc/ada/s-interr-sigaction.adb b/main/gcc/ada/s-interr-sigaction.adb index 1daca4d1a3c..2e646a20422 100644 --- a/main/gcc/ada/s-interr-sigaction.adb +++ b/main/gcc/ada/s-interr-sigaction.adb @@ -616,13 +616,13 @@ package body System.Interrupts is end Is_Blocked; task body Server_Task is + Ignore : constant Boolean := Utilities.Make_Independent; + Desc : Handler_Desc renames Descriptors (Interrupt); Self_Id : constant Task_Id := STPO.Self; Temp : Parameterless_Handler; begin - Utilities.Make_Independent; - loop while Interrupt_Count (Interrupt) > 0 loop Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1; diff --git a/main/gcc/ada/s-interr-vms.adb b/main/gcc/ada/s-interr-vms.adb deleted file mode 100644 index 7ef3b1cbbde..00000000000 --- a/main/gcc/ada/s-interr-vms.adb +++ /dev/null @@ -1,1129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is an OpenVMS/Alpha version of this package - --- Invariants: - --- Once we associate a Server_Task with an interrupt, the task never --- goes away, and we never remove the association. - --- There is no more than one interrupt per Server_Task and no more than --- one Server_Task per interrupt. - --- Within this package, the lock L is used to protect the various status --- tables. If there is a Server_Task associated with an interrupt, we use --- the per-task lock of the Server_Task instead so that we protect the --- status between Interrupt_Manager and Server_Task. Protection among --- service requests are done using User Request to Interrupt_Manager --- rendezvous. - -with Ada.Task_Identification; -with Ada.Unchecked_Conversion; - -with System.Task_Primitives; -with System.Interrupt_Management; - -with System.Interrupt_Management.Operations; -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Task_Primitives.Operations; -with System.Task_Primitives.Interrupt_Operations; -with System.Storage_Elements; -with System.Tasking.Utilities; - -with System.Tasking.Rendezvous; -pragma Elaborate_All (System.Tasking.Rendezvous); - -with System.Tasking.Initialization; -with System.Parameters; - -package body System.Interrupts is - - use Tasking; - use System.Parameters; - - package POP renames System.Task_Primitives.Operations; - package PIO renames System.Task_Primitives.Interrupt_Operations; - package IMNG renames System.Interrupt_Management; - package IMOP renames System.Interrupt_Management.Operations; - - function To_System is new Ada.Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_Id); - - ----------------- - -- Local Tasks -- - ----------------- - - -- WARNING: System.Tasking.Stages performs calls to this task with - -- low-level constructs. Do not change this spec without synchronizing it. - - task Interrupt_Manager is - entry Detach_Interrupt_Entries (T : Task_Id); - - entry Initialize (Mask : IMNG.Interrupt_Mask); - - entry Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - entry Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean); - - entry Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - entry Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Interrupt : Interrupt_ID); - - entry Block_Interrupt (Interrupt : Interrupt_ID); - - entry Unblock_Interrupt (Interrupt : Interrupt_ID); - - entry Ignore_Interrupt (Interrupt : Interrupt_ID); - - entry Unignore_Interrupt (Interrupt : Interrupt_ID); - - pragma Interrupt_Priority (System.Interrupt_Priority'Last); - end Interrupt_Manager; - - task type Server_Task (Interrupt : Interrupt_ID) is - pragma Priority (System.Interrupt_Priority'Last); - -- Note: the above pragma Priority is strictly speaking improper since - -- it is outside the range of allowed priorities, but the compiler - -- treats system units specially and does not apply this range checking - -- rule to system units. - - end Server_Task; - - type Server_Task_Access is access Server_Task; - - ------------------------------- - -- Local Types and Variables -- - ------------------------------- - - type Entry_Assoc is record - T : Task_Id; - E : Task_Entry_Index; - end record; - - type Handler_Assoc is record - H : Parameterless_Handler; - Static : Boolean; -- Indicates static binding; - end record; - - User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := - (others => (null, Static => False)); - pragma Volatile_Components (User_Handler); - -- Holds the protected procedure handler (if any) and its Static - -- information for each interrupt. A handler is a Static one if it is - -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, - -- not static) - - User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := - (others => (T => Null_Task, E => Null_Task_Entry)); - pragma Volatile_Components (User_Entry); - -- Holds the task and entry index (if any) for each interrupt - - Blocked : constant array (Interrupt_ID'Range) of Boolean := - (others => False); - -- ??? pragma Volatile_Components (Blocked); - -- True iff the corresponding interrupt is blocked in the process level - - Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Volatile_Components (Ignored); - -- True iff the corresponding interrupt is blocked in the process level - - Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id := - (others => Null_Task); - -- ??? pragma Volatile_Components (Last_Unblocker); - -- Holds the ID of the last Task which Unblocked this Interrupt. It - -- contains Null_Task if no tasks have ever requested the Unblocking - -- operation or the Interrupt is currently Blocked. - - Server_ID : array (Interrupt_ID'Range) of Task_Id := - (others => Null_Task); - pragma Atomic_Components (Server_ID); - -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is - -- needed to accomplish locking per Interrupt base. Also is needed to - -- decide whether to create a new Server_Task. - - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. - - type Registered_Handler; - type R_Link is access all Registered_Handler; - - type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; - end record; - - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; - - Access_Hold : Server_Task_Access; - -- variable used to allocate Server_Task using "new" - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- See if the Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - - begin - -- This routine registers the Handler as usable for Dynamic Interrupt - -- Handler. Routines attaching and detaching Handler dynamically should - -- first consult if the Handler is registered. A Program Error should be - -- raised if it is not registered. - - -- The pragma Interrupt_Handler can only appear in the library level PO - -- definition and instantiation. Therefore, we do not need to implement - -- Unregistering operation. Neither we need to protect the queue - -- structure using a Lock. - - pragma Assert (Handler_Addr /= System.Null_Address); - - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; - end Register_Interrupt_Handler; - - ------------------- - -- Is_Registered -- - ------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - type Fat_Ptr is record - Object_Addr : System.Address; - Handler_Addr : System.Address; - end record; - - function To_Fat_Ptr is new Ada.Unchecked_Conversion - (Parameterless_Handler, Fat_Ptr); - - Ptr : R_Link; - Fat : Fat_Ptr; - - begin - if Handler = null then - return True; - end if; - - Fat := To_Fat_Ptr (Handler); - - Ptr := Registered_Handler_Head; - while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then - return True; - end if; - - Ptr := Ptr.Next; - end loop; - - return False; - end Is_Registered; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - begin - return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); - end Is_Reserved; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return User_Entry (Interrupt).T /= Null_Task; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return User_Handler (Interrupt).H /= null; - end Is_Handler_Attached; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Blocked (Interrupt); - end Is_Blocked; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Ignored (Interrupt); - end Is_Ignored; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - -- ??? Since Parameterless_Handler is not Atomic, the current - -- implementation is wrong. We need a new service in Interrupt_Manager - -- to ensure atomicity. - - return User_Handler (Interrupt).H; - end Current_Handler; - - -------------------- - -- Attach_Handler -- - -------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the previous - -- handler's binding status (i.e. we do not care if it is a dynamic or - -- static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); - end Attach_Handler; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - -- Calling this procedure with New_Handler = null and Static = True means - -- we want to detach the current handler regardless of the previous - -- handler's binding status (i.e. do not care if it is dynamic or static - -- handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - -- Calling this procedure with Static = True means we want to Detach the - -- current handler regardless of the previous handler's binding status - -- (i.e. do not care if it is a dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Storage_Elements.To_Address - (Storage_Elements.Integer_Address (Interrupt)); - end Reference; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - -- This procedure raises a Program_Error if it tries to - -- bind an interrupt to which an Entry or a Procedure is - -- already bound. - - procedure Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - end Bind_Interrupt_To_Entry; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_Id) is - begin - Interrupt_Manager.Detach_Interrupt_Entries (T); - end Detach_Interrupt_Entries; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Block_Interrupt (Interrupt); - end Block_Interrupt; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Unblock_Interrupt (Interrupt); - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Last_Unblocker (Interrupt); - end Unblocked_By; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Ignore_Interrupt (Interrupt); - end Ignore_Interrupt; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Unignore_Interrupt (Interrupt); - end Unignore_Interrupt; - - ----------------------- - -- Interrupt_Manager -- - ----------------------- - - task body Interrupt_Manager is - - -------------------- - -- Local Routines -- - -------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - ---------------------------------- - -- Unprotected_Exchange_Handler -- - ---------------------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - - -- In case we have an Interrupt Entry already installed. - -- raise a program error. (propagate it to the caller). - - raise Program_Error with "an interrupt is already installed"; - end if; - - -- Note: A null handler with Static=True will pass the following - -- check. That is the case when we want to Detach a handler - -- regardless of the Static status of the current_Handler. We don't - -- check anything if Restoration is True, since we may be detaching - -- a static handler to restore a dynamic one. - - if not Restoration and then not Static - - -- Tries to overwrite a static Interrupt Handler with a - -- dynamic Handler - - and then (User_Handler (Interrupt).Static - - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. - - or else not Is_Registered (New_Handler)) - then - raise Program_Error with - "trying to overwrite a static interrupt handler with a " & - "dynamic handler"; - end if; - - -- The interrupt should no longer be ignored if it was ever ignored - - Ignored (Interrupt) := False; - - -- Save the old handler - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := New_Handler; - - if New_Handler = null then - - -- The null handler means we are detaching the handler - - User_Handler (Interrupt).Static := False; - - else - User_Handler (Interrupt).Static := Static; - end if; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_Id info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - Access_Hold := new Server_Task (Interrupt); - Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); - else - POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); - end if; - - end Unprotected_Exchange_Handler; - - -------------------------------- - -- Unprotected_Detach_Handler -- - -------------------------------- - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - - -- In case we have an Interrupt Entry installed, raise a program - -- error, (propagate it to the caller). - - raise Program_Error with - "an interrupt entry is already installed"; - end if; - - -- Note : Static = True will pass the following check. That is the - -- case when we want to detach a handler regardless of the static - -- status of the current_Handler. - - if not Static and then User_Handler (Interrupt).Static then - - -- Tries to detach a static Interrupt Handler, raise program error - - raise Program_Error with - "trying to detach a static interrupt handler"; - end if; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - - -- The new handler - - User_Handler (Interrupt).H := null; - User_Handler (Interrupt).Static := False; - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); - - end Unprotected_Detach_Handler; - - -- Start of processing for Interrupt_Manager - - begin - -- By making this task independent of master, when the process goes - -- away, the Interrupt_Manager will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - -- Environment task gets its own interrupt mask, saves it, and then - -- masks all interrupts except the Keep_Unmasked set. - - -- During rendezvous, the Interrupt_Manager receives the old interrupt - -- mask of the environment task, and sets its own interrupt mask to that - -- value. - - -- The environment task will call the entry of Interrupt_Manager some - -- during elaboration of the body of this package. - - accept Initialize (Mask : IMNG.Interrupt_Mask) do - pragma Warnings (Off, Mask); - null; - end Initialize; - - -- Note: All tasks in RTS will have all the Reserve Interrupts being - -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked - -- when created. - - -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. - -- We mask the Interrupt in this particular task so that "sigwait" is - -- possible to catch an explicitly sent Abort_Task_Interrupt from the - -- Server_Tasks. - - -- This sigwaiting is needed so that we make sure a Server_Task is out - -- of its own sigwait state. This extra synchronization is necessary to - -- prevent following scenarios. - - -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the - -- Server_Task then changes its own interrupt mask (OS level). - -- If an interrupt (corresponding to the Server_Task) arrives - -- in the mean time we have the Interrupt_Manager unmasked and - -- the Server_Task waiting on sigwait. - - -- 2) For unbinding handler, we install a default action in the - -- Interrupt_Manager. POSIX.1c states that the result of using - -- "sigwait" and "sigaction" simultaneously on the same interrupt - -- is undefined. Therefore, we need to be informed from the - -- Server_Task of the fact that the Server_Task is out of its - -- sigwait stage. - - loop - -- A block is needed to absorb Program_Error exception - - declare - Old_Handler : Parameterless_Handler; - - begin - select - - accept Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static, Restoration); - end Attach_Handler; - - or accept Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - or accept Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Detach_Handler (Interrupt, Static); - end Detach_Handler; - - or accept Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Interrupt : Interrupt_ID) - do - -- if there is a binding already (either a procedure or an - -- entry), raise Program_Error (propagate it to the caller). - - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - raise Program_Error with - "a binding for this interrupt is already present"; - end if; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); - - -- Indicate the attachment of Interrupt Entry in ATCB. - -- This is need so that when an Interrupt Entry task - -- terminates the binding can be cleaned. - -- The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_Id info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - - Access_Hold := new Server_Task (Interrupt); - Server_ID (Interrupt) := - To_System (Access_Hold.all'Identity); - else - POP.Wakeup (Server_ID (Interrupt), - Interrupt_Server_Idle_Sleep); - end if; - end Bind_Interrupt_To_Entry; - - or accept Detach_Interrupt_Entries (T : Task_Id) - do - for J in Interrupt_ID'Range loop - if not Is_Reserved (J) then - if User_Entry (J).T = T then - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (J) := False; - User_Entry (J) := - Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); - end if; - end if; - end loop; - - -- Indicate in ATCB that no Interrupt Entries are attached - - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; - - or accept Block_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Block_Interrupt; - - or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Unblock_Interrupt; - - or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Ignore_Interrupt; - - or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Unignore_Interrupt; - - end select; - - exception - -- If there is a program error we just want to propagate it to the - -- caller and do not want to stop this task. - - when Program_Error => - null; - - when others => - pragma Assert (False); - null; - end; - end loop; - end Interrupt_Manager; - - ----------------- - -- Server_Task -- - ----------------- - - task body Server_Task is - Self_ID : constant Task_Id := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_Id; - Tmp_Entry_Index : Task_Entry_Index; - Intwait_Mask : aliased IMNG.Interrupt_Mask; - - begin - -- By making this task independent of master, when the process - -- goes away, the Server_Task will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - -- Install default action in system level - - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - - -- Set up the mask (also clears the event flag) - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); - - -- Remember the Interrupt_ID for Abort_Task - - PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); - - -- Note: All tasks in RTS will have all the Reserve Interrupts - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. - - loop - System.Tasking.Initialization.Defer_Abort (Self_ID); - - -- A Handler or an Entry is installed. At this point all tasks - -- mask for the Interrupt is masked. Catch the Interrupt using - -- sigwait. - - -- This task may wake up from sigwait by receiving an interrupt - -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding - -- a Procedure Handler or an Entry. Or it could be a wake up - -- from status change (Unblocked -> Blocked). If that is not - -- the case, we should execute the attached Procedure or Entry. - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - -- No Interrupt binding. If there is an interrupt, - -- Interrupt_Manager will take default action. - - Self_ID.Common.State := Interrupt_Server_Idle_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); - Self_ID.Common.State := Runnable; - - else - Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; - Self_ID.Common.State := Runnable; - - if not (Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level - < Self_ID.ATC_Nesting_Level) - then - if User_Handler (Interrupt).H /= null then - Tmp_Handler := User_Handler (Interrupt).H; - - -- RTS calls should not be made with self being locked - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - Tmp_Handler.all; - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - elsif User_Entry (Interrupt).T /= Null_Task then - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - - -- RTS calls should not be made with self being locked - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - end if; - end if; - end if; - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - - -- Undefer abort here to allow a window for this task - -- to be aborted at the time of system shutdown. - end loop; - end Server_Task; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) return Boolean - is - pragma Warnings (Off, Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt tasks are gone. - - if not Interrupt_Manager'Terminated then - for N in reverse Object.Previous_Handlers'Range loop - Interrupt_Manager.Attach_Handler - (New_Handler => Object.Previous_Handlers (N).Handler, - Interrupt => Object.Previous_Handlers (N).Interrupt, - Static => Object.Previous_Handlers (N).Static, - Restoration => True); - end loop; - end if; - - Tasking.Protected_Objects.Entries.Finalize - (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); - end Finalize; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) return Boolean - is - pragma Warnings (Off, Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) - is - begin - for N in New_Handlers'Range loop - - -- We need a lock around this ??? - - Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; - Object.Previous_Handlers (N).Static := User_Handler - (New_Handlers (N).Interrupt).Static; - - -- We call Exchange_Handler and not directly Interrupt_Manager. - -- Exchange_Handler so we get the Is_Reserved check. - - Exchange_Handler - (Old_Handler => Object.Previous_Handlers (N).Handler, - New_Handler => New_Handlers (N).Handler, - Interrupt => New_Handlers (N).Interrupt, - Static => True); - end loop; - end Install_Handlers; - - --------------------------------- - -- Install_Restricted_Handlers -- - --------------------------------- - - procedure Install_Restricted_Handlers - (Prio : Any_Priority; - Handlers : New_Handler_Array) - is - pragma Unreferenced (Prio); - begin - for N in Handlers'Range loop - Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); - end loop; - end Install_Restricted_Handlers; - --- Elaboration code for package System.Interrupts - -begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent - - Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - - -- During the elaboration of this package body we want RTS to inherit the - -- interrupt mask from the Environment Task. - - -- The Environment Task should have gotten its mask from the enclosing - -- process during the RTS start up. (See in s-inmaop.adb). Pass the - -- Interrupt_Mask of the Environment task to the Interrupt_Manager. - - -- Note : At this point we know that all tasks (including RTS internal - -- servers) are masked for non-reserved signals (see s-taprop.adb). Only - -- the Interrupt_Manager will have masks set up differently inheriting the - -- original Environment Task's mask. - - Interrupt_Manager.Initialize (IMOP.Environment_Mask); -end System.Interrupts; diff --git a/main/gcc/ada/s-interr.adb b/main/gcc/ada/s-interr.adb index cbf8f03117f..3c988af5a02 100644 --- a/main/gcc/ada/s-interr.adb +++ b/main/gcc/ada/s-interr.adb @@ -52,6 +52,7 @@ -- There is no more than one interrupt per Server_Task and no more than one -- Server_Task per interrupt. +with Ada.Exceptions; with Ada.Task_Identification; with System.Task_Primitives; @@ -60,6 +61,8 @@ with System.Interrupt_Management; with System.Interrupt_Management.Operations; pragma Elaborate_All (System.Interrupt_Management.Operations); +with System.IO; + with System.Task_Primitives.Operations; with System.Task_Primitives.Interrupt_Operations; with System.Storage_Elements; @@ -678,6 +681,10 @@ package body System.Interrupts is ----------------------- task body Interrupt_Manager is + -- By making this task independent of master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; --------------------- -- Local Variables -- @@ -940,11 +947,6 @@ package body System.Interrupts is -- Start of processing for Interrupt_Manager begin - -- By making this task independent of master, when the process - -- goes away, the Interrupt_Manager will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - -- Environment task gets its own interrupt mask, saves it, and then -- masks all interrupts except the Keep_Unmasked set. @@ -1221,9 +1223,10 @@ package body System.Interrupts is when Program_Error => null; - when others => + when X : others => + System.IO.Put_Line ("Exception in Interrupt_Manager"); + System.IO.Put_Line (Ada.Exceptions.Exception_Information (X)); pragma Assert (False); - null; end; end loop; end Interrupt_Manager; @@ -1233,6 +1236,11 @@ package body System.Interrupts is ----------------- task body Server_Task is + -- By making this task independent of master, when the process goes + -- away, the Server_Task will terminate gracefully. + + Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; + Intwait_Mask : aliased IMNG.Interrupt_Mask; Ret_Interrupt : Interrupt_ID; Self_ID : constant Task_Id := Self; @@ -1241,11 +1249,6 @@ package body System.Interrupts is Tmp_Entry_Index : Task_Entry_Index; begin - -- By making this task independent of master, when the process goes - -- away, the Server_Task will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - -- Install default action in system level IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); @@ -1302,7 +1305,7 @@ package body System.Interrupts is elsif Blocked (Interrupt) then - -- Interrupt is blocked. Stay here, so we won't catch it + -- Interrupt is blocked, stay here, so we won't catch it Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep; POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep); diff --git a/main/gcc/ada/s-interr.ads b/main/gcc/ada/s-interr.ads index 7c3ed56f9dc..c1ac164f124 100644 --- a/main/gcc/ada/s-interr.ads +++ b/main/gcc/ada/s-interr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -156,9 +156,9 @@ package System.Interrupts is function Is_Ignored (Interrupt : Interrupt_ID) return Boolean; -- Comment needed ??? - -- Note : Direct calls to sigaction, sigprocmask, thr_sigsetmask or any + -- Note : Direct calls to sigaction, sigprocmask, thr_sigsetmask, or any -- other low-level interface that changes the signal action or signal mask - -- needs a careful thought. + -- needs careful thought. -- One may achieve the effect of system calls first making RTS blocked (by -- calling Block_Interrupt) for the signal under consideration. This will diff --git a/main/gcc/ada/s-intman-vms.adb b/main/gcc/ada/s-intman-vms.adb deleted file mode 100644 index 0f198f15226..00000000000 --- a/main/gcc/ada/s-intman-vms.adb +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - -package body System.Interrupt_Management is - - ---------------- - -- Initialize -- - ---------------- - - Initialized : Boolean := False; - - procedure Initialize is - use System.OS_Interface; - Status : Cond_Value_Type; - - begin - if Initialized then - return; - end if; - - Initialized := True; - Abort_Task_Interrupt := Interrupt_ID_0; - -- Unused - - Reserve := Reserve or Keep_Unmasked or Keep_Masked; - Reserve (Interrupt_ID_0) := True; - - Sys_Crembx - (Status => Status, - Prmflg => 0, - Chan => Rcv_Interrupt_Chan, - Maxmsg => Interrupt_ID'Size, - Bufquo => Interrupt_Bufquo, - Lognam => "GNAT_Interrupt_Mailbox", - Flags => CMB_M_READONLY); - pragma Assert ((Status and 1) = 1); - - Sys_Assign - (Status => Status, - Devnam => "GNAT_Interrupt_Mailbox", - Chan => Snd_Interrupt_Chan, - Flags => AGN_M_WRITEONLY); - pragma Assert ((Status and 1) = 1); - end Initialize; - -end System.Interrupt_Management; diff --git a/main/gcc/ada/s-intman-vms.ads b/main/gcc/ada/s-intman-vms.ads deleted file mode 100644 index cc5124217ca..00000000000 --- a/main/gcc/ada/s-intman-vms.ads +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2009, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version of this package - --- This package encapsulates and centralizes information about all uses of --- interrupts (or signals), including the target-dependent mapping of --- interrupts (or signals) to exceptions. - --- PLEASE DO NOT add any with-clauses to this package - --- PLEASE DO NOT put any subprogram declarations with arguments of type --- Interrupt_ID into the visible part of this package. - --- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and --- adding more operations to that type would be illegal according to the Ada --- Reference Manual. (This is the reason why the signals sets below are --- implemented as visible arrays rather than functions.) - -with System.OS_Interface; - -package System.Interrupt_Management is - pragma Preelaborate; - - type Interrupt_Mask is limited private; - - type Interrupt_ID is new System.OS_Interface.Signal; - - type Interrupt_Set is array (Interrupt_ID) of Boolean; - - -- The following objects serve as constants, but are initialized in the - -- body to aid portability. This permits us to use more portable names for - -- interrupts, where distinct names may map to the same interrupt ID - -- value. For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. If we have the - -- convention that ID zero is not used for any "real" signals, and SIGRARE - -- = 0 when SIGRARE is not one of the locally supported signals, we can - -- write: - -- Reserved (SIGRARE) := true; - -- Then the initialization code will be portable. - - Abort_Task_Interrupt : Interrupt_ID; - -- The interrupt that is used to implement task abort, if an interrupt is - -- used for that purpose. This is one of the reserved interrupts. - - Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept - -- unmasked at all times, except (perhaps) for short critical sections. - -- This includes interrupts that are mapped to exceptions (see - -- System.Interrupt_Exceptions.Is_Exception), but may also include - -- interrupts (e.g. timer) that need to be kept unmasked for other - -- reasons. Where interrupts are implemented as OS signals, and signal - -- masking is per-task, the interrupt should be unmasked in ALL TASKS. - - Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that cannot be permitted - -- to be attached to a user handler. The possible reasons are many. For - -- example it may be mapped to an exception used to implement task abort. - - Keep_Masked : Interrupt_Set := (others => False); - -- Keep_Masked (I) is true iff the interrupt I must always be masked. - -- Where interrupts are implemented as OS signals, and signal masking is - -- per-task, the interrupt should be masked in ALL TASKS. There might not - -- be any interrupts in this class, depending on the environment. For - -- example, if interrupts are OS signals and signal masking is per-task, - -- use of the sigwait operation requires the signal be masked in all tasks. - - procedure Initialize; - -- Initialize the various variables defined in this package. - -- This procedure must be called before accessing any object from this - -- package and can be called multiple times. - -private - use type System.OS_Interface.unsigned_long; - - type Interrupt_Mask is new System.OS_Interface.sigset_t; - - -- Interrupts on VMS are implemented with a mailbox. A QIO read is - -- registered on the Rcv channel and the interrupt occurs by registering - -- a QIO write on the Snd channel. The maximum number of pending - -- interrupts is arbitrarily set at 1000. One nice feature of using - -- a mailbox is that it is trivially extendable to cross process - -- interrupts. - - Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; - Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; - Interrupt_Mailbox : Interrupt_ID := 0; - Interrupt_Bufquo : System.OS_Interface.unsigned_long := - 1000 * (Interrupt_ID'Size / 8); - -end System.Interrupt_Management; diff --git a/main/gcc/ada/s-intman.ads b/main/gcc/ada/s-intman.ads index 5f3f4d50089..71a1cefcc6e 100644 --- a/main/gcc/ada/s-intman.ads +++ b/main/gcc/ada/s-intman.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -75,9 +75,9 @@ package System.Interrupt_Management is -- used for that purpose. This is one of the reserved interrupts. Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is one that must that - -- must be kept unmasked at all times, except (perhaps) for short critical - -- sections. This includes interrupts that are mapped to exceptions (see + -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept + -- unmasked at all times, except (perhaps) for short critical sections. + -- This includes interrupts that are mapped to exceptions (see -- System.Interrupt_Exceptions.Is_Exception), but may also include -- interrupts (e.g. timer) that need to be kept unmasked for other -- reasons. Where interrupts are implemented as OS signals, and signal diff --git a/main/gcc/ada/s-mantis.adb b/main/gcc/ada/s-mantis.adb index 035362107ac..04f6e5a5c27 100644 --- a/main/gcc/ada/s-mantis.adb +++ b/main/gcc/ada/s-mantis.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-mantis.ads b/main/gcc/ada/s-mantis.ads index de5a6f2619c..51692999256 100644 --- a/main/gcc/ada/s-mantis.ads +++ b/main/gcc/ada/s-mantis.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-mastop-vms.adb b/main/gcc/ada/s-mastop-vms.adb deleted file mode 100644 index 7426f50a5ec..00000000000 --- a/main/gcc/ada/s-mastop-vms.adb +++ /dev/null @@ -1,274 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for Alpha/VMS) -- --- -- --- 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. -- --- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of System.Machine_State_Operations is for use on --- Alpha systems running VMS. - -with System.Memory; -with System.Aux_DEC; use System.Aux_DEC; -with Ada.Unchecked_Conversion; - -package body System.Machine_State_Operations is - - subtype Cond_Value_Type is Unsigned_Longword; - - -- Record layouts copied from Starlet - - type ICB_Fflags_Bits_Type is record - Exception_Frame : Boolean; - Ast_Frame : Boolean; - Bottom_Of_Stack : Boolean; - Base_Frame : Boolean; - Filler_1 : Unsigned_20; - end record; - - for ICB_Fflags_Bits_Type use record - Exception_Frame at 0 range 0 .. 0; - Ast_Frame at 0 range 1 .. 1; - Bottom_Of_Stack at 0 range 2 .. 2; - Base_Frame at 0 range 3 .. 3; - Filler_1 at 0 range 4 .. 23; - end record; - for ICB_Fflags_Bits_Type'Size use 24; - - type ICB_Hdr_Quad_Type is record - Context_Length : Unsigned_Longword; - Fflags_Bits : ICB_Fflags_Bits_Type; - Block_Version : Unsigned_Byte; - end record; - - for ICB_Hdr_Quad_Type use record - Context_Length at 0 range 0 .. 31; - Fflags_Bits at 4 range 0 .. 23; - Block_Version at 7 range 0 .. 7; - end record; - for ICB_Hdr_Quad_Type'Size use 64; - - type Invo_Context_Blk_Type is record - - Hdr_Quad : ICB_Hdr_Quad_Type; - -- The first quadword contains: - -- o The length of the structure in bytes (a longword field) - -- o The frame flags (a 3 byte field of bits) - -- o The version number (a 1 byte field) - - Procedure_Descriptor : Unsigned_Quadword; - -- The address of the procedure descriptor for the procedure - - Program_Counter : Integer_64; - -- The current PC of a given procedure invocation - - Processor_Status : Integer_64; - -- The current PS of a given procedure invocation - - Ireg : Unsigned_Quadword_Array (0 .. 30); - Freg : Unsigned_Quadword_Array (0 .. 30); - -- The register contents areas. 31 for scalars, 31 for float - - System_Defined : Unsigned_Quadword_Array (0 .. 1); - -- The following is an "internal" area that's reserved for use by - -- the operating system. It's size may vary over time. - - -- Chfctx_Addr : Unsigned_Quadword; - -- Defined as a comment since it overlaps other fields - - Filler_1 : String (1 .. 0); - -- Align to octaword - end record; - - for Invo_Context_Blk_Type use record - Hdr_Quad at 0 range 0 .. 63; - Procedure_Descriptor at 8 range 0 .. 63; - Program_Counter at 16 range 0 .. 63; - Processor_Status at 24 range 0 .. 63; - Ireg at 32 range 0 .. 1983; - Freg at 280 range 0 .. 1983; - System_Defined at 528 range 0 .. 127; - - -- Component representation spec(s) below are defined as - -- comments since they overlap other fields - - -- Chfctx_Addr at 528 range 0 .. 63; - - Filler_1 at 544 range 0 .. -1; - end record; - for Invo_Context_Blk_Type'Size use 4352; - - subtype Invo_Handle_Type is Unsigned_Longword; - - type Invo_Handle_Access_Type is access all Invo_Handle_Type; - - function Fetch is new Fetch_From_Address (Code_Loc); - - function To_Invo_Handle_Access is new Ada.Unchecked_Conversion - (Machine_State, Invo_Handle_Access_Type); - - function To_Machine_State is new Ada.Unchecked_Conversion - (System.Address, Machine_State); - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - begin - return To_Machine_State - (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); - end Allocate_Machine_State; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - -- The starting address is in the second longword pointed to by Loc - - return Fetch (System.Aux_DEC."+" (Loc, 8)); - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - procedure Get_Invo_Context ( - Result : out Unsigned_Longword; -- return value - Invo_Handle : Invo_Handle_Type; - Invo_Context : out Invo_Context_Blk_Type); - - pragma Import (External, Get_Invo_Context); - - pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", - (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Value, Reference)); - - Asm_Call_Size : constant := 4; - -- Under VMS a call - -- asm instruction takes 4 bytes. So we must remove this amount. - - ICB : Invo_Context_Blk_Type; - Status : Cond_Value_Type; - - begin - Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); - - if (Status and 1) /= 1 then - return Code_Loc (System.Null_Address); - end if; - - return Code_Loc (ICB.Program_Counter - Asm_Call_Size); - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - use System.Storage_Elements; - - begin - return Invo_Handle_Type'Size / 8; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame (M : Machine_State) is - procedure Get_Prev_Invo_Handle ( - Result : out Invo_Handle_Type; -- return value - ICB : Invo_Handle_Type); - - pragma Import (External, Get_Prev_Invo_Handle); - - pragma Import_Valued_Procedure - (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", - (Invo_Handle_Type, Invo_Handle_Type), - (Value, Value)); - - Prev_Handle : aliased Invo_Handle_Type; - - begin - Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); - To_Invo_Handle_Access (M).all := Prev_Handle; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - - procedure Get_Curr_Invo_Context - (Invo_Context : out Invo_Context_Blk_Type); - - pragma Import (External, Get_Curr_Invo_Context); - - pragma Import_Valued_Procedure - (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", - (Invo_Context_Blk_Type), - (Reference)); - - procedure Get_Invo_Handle ( - Result : out Invo_Handle_Type; -- return value - Invo_Context : Invo_Context_Blk_Type); - - pragma Import (External, Get_Invo_Handle); - - pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", - (Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Reference)); - - ICB : Invo_Context_Blk_Type; - Invo_Handle : aliased Invo_Handle_Type; - - begin - Get_Curr_Invo_Context (ICB); - Get_Invo_Handle (Invo_Handle, ICB); - To_Invo_Handle_Access (M).all := Invo_Handle; - Pop_Frame (M, System.Null_Address); - end Set_Machine_State; - -end System.Machine_State_Operations; diff --git a/main/gcc/ada/s-mastop.ads b/main/gcc/ada/s-mastop.ads index 93f06f8f24a..216d79bbd15 100644 --- a/main/gcc/ada/s-mastop.ads +++ b/main/gcc/ada/s-mastop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 +40,10 @@ with System.Storage_Elements; package System.Machine_State_Operations is subtype Code_Loc is System.Address; - -- Code location used in building exception tables and for call - -- addresses when propagating an exception (also traceback table) - -- Values of this type are created by using Label'Address or - -- extracted from machine states using Get_Code_Loc. + -- Code location used in building exception tables and for call addresses + -- when propagating an exception (also traceback table) Values of this + -- type are created by using Label'Address or extracted from machine + -- states using Get_Code_Loc. type Machine_State is new System.Address; -- The table based exception handling approach (see a-except.adb) isolates @@ -66,31 +66,28 @@ package System.Machine_State_Operations is -- The initial value of type Machine_State is created by the low level -- routine that actually raises an exception using the special builtin - -- _builtin_machine_state. This value will typically encode the value - -- of the program counter, and relevant registers. The following - -- operations are defined on Machine_State values: + -- _builtin_machine_state. This value will typically encode the value of + -- the program counter, and relevant registers. The following operations + -- are defined on Machine_State values: function Get_Code_Loc (M : Machine_State) return Code_Loc; - -- This function extracts the program counter value from a machine - -- state, which the caller uses for searching the exception tables, - -- and also for recording entries in the traceback table. The call - -- returns a value of Null_Loc if the machine state represents the - -- outer level, or some other frame for which no information can be - -- provided. + -- This function extracts the program counter value from a machine state, + -- which the caller uses for searching the exception tables, and also for + -- recording entries in the traceback table. The call returns a value of + -- Null_Loc if the machine state represents the outer level, or some other + -- frame for which no information can be provided. procedure Pop_Frame (M : Machine_State); -- This procedure pops the machine state M so that it represents the - -- call point, as though the current subprogram had returned. It - -- changes only the value referenced by M, and does not affect - -- the current stack environment. + -- call point, as though the current subprogram had returned. It changes + -- only the value referenced by M, and does not affect the current stack + -- environment. function Fetch_Code (Loc : Code_Loc) return Code_Loc; - -- Some architectures (notably VMS) use a descriptor to describe - -- a subprogram address. This function computes the actual starting + -- Some architectures (notably HPUX) use a descriptor to describe a + -- subprogram address. This function computes the actual starting -- address of the code from Loc. -- - -- ??? This function will go away when 'Code_Address is fixed on VMS. - -- -- Do not add pragma Inline to this function: there is a curious -- interaction between rtsfind and front-end inlining. The exception -- declaration in s-auxdec calls rtsfind, which forces several other system @@ -98,10 +95,10 @@ package System.Machine_State_Operations is -- compile the corresponding bodies so that inlining can take place. One -- of these packages is s-mastop, which depends on s-auxdec, which is still -- being compiled: we have not seen all the declarations in it yet, so we - -- get confused semantic errors. + -- get confused semantic errors ??? procedure Set_Machine_State (M : Machine_State); - -- This routine sets M from the current machine state. It is called - -- when an exception is initially signalled to initialize the state. + -- This routine sets M from the current machine state. It is called when an + -- exception is initially signalled to initialize the state. end System.Machine_State_Operations; diff --git a/main/gcc/ada/s-memcop.ads b/main/gcc/ada/s-memcop.ads index 96219f1e126..fc2403fdfbf 100644 --- a/main/gcc/ada/s-memcop.ads +++ b/main/gcc/ada/s-memcop.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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 -- diff --git a/main/gcc/ada/s-memory-vms_64.adb b/main/gcc/ada/s-memory-vms_64.adb deleted file mode 100644 index 7a08f7d0799..00000000000 --- a/main/gcc/ada/s-memory-vms_64.adb +++ /dev/null @@ -1,230 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS 64 bit implementation of this package - --- This implementation assumes that the underlying malloc/free/realloc --- implementation is thread safe, and thus, no additional lock is required. --- Note that we still need to defer abort because on most systems, an --- asynchronous signal (as used for implementing asynchronous abort of --- task) cannot safely be handled while malloc is executing. - --- If you are not using Ada constructs containing the "abort" keyword, then --- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from --- this unit. - -pragma Compiler_Unit_Warning; - -with Ada.Exceptions; -with System.Soft_Links; -with System.Parameters; -with System.CRTL; - -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; - - procedure c_free (Ptr : System.Address) - renames System.CRTL.free; - - function c_realloc - (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address - renames System.CRTL.realloc; - - Gnat_Heap_Size : Integer; - pragma Import (C, Gnat_Heap_Size, "__gl_heap_size"); - -- Set by Feature logical GNAT$NO_MALLOC_64 and/or Binder switch -Hnn - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Gnat_Heap_Size = 32 then - return Alloc32 (Size); - end if; - - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- 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; - end if; - - if Parameters.No_Abort then - Result := c_malloc (System.CRTL.size_t (Actual_Size)); - else - Abort_Defer.all; - Result := c_malloc (System.CRTL.size_t (Actual_Size)); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - ------------- - -- Alloc32 -- - ------------- - - function Alloc32 (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- 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; - end if; - - if Parameters.No_Abort then - Result := C_malloc32 (Actual_Size); - else - Abort_Defer.all; - Result := C_malloc32 (Actual_Size); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc32; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - if Parameters.No_Abort then - c_free (Ptr); - else - Abort_Defer.all; - c_free (Ptr); - Abort_Undefer.all; - end if; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - - begin - if Gnat_Heap_Size = 32 then - return Realloc32 (Ptr, Size); - end if; - - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - if Parameters.No_Abort then - Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size)); - else - Abort_Defer.all; - Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size)); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - - --------------- - -- Realloc32 -- - --------------- - - function Realloc32 - (Ptr : System.Address; - Size : size_t) - 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"); - end if; - - if Parameters.No_Abort then - Result := C_realloc32 (Ptr, Actual_Size); - else - Abort_Defer.all; - Result := C_realloc32 (Ptr, Actual_Size); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc32; -end System.Memory; diff --git a/main/gcc/ada/s-memory-vms_64.ads b/main/gcc/ada/s-memory-vms_64.ads deleted file mode 100644 index 464446a8b2e..00000000000 --- a/main/gcc/ada/s-memory-vms_64.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the low level memory allocation/deallocation --- mechanisms used by GNAT for VMS 64 bit. - --- To provide an alternate implementation, simply recompile the modified --- body of this package with gnatmake -u -a -g s-memory.adb and make sure --- that the ali and object files for this unit are found in the object --- search path. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -pragma Compiler_Unit_Warning; - -package System.Memory is - pragma Elaborate_Body; - - type size_t is mod 2 ** Standard'Address_Size; - -- Note: the reason we redefine this here instead of using the - -- definition in Interfaces.C is that we do not want to drag in - -- all of Interfaces.C just because System.Memory is used. - - function Alloc (Size : size_t) return System.Address; - -- This is the low level allocation routine. Given a size in storage - -- units, it returns the address of a maximally aligned block of - -- 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 - -- exception is raised with a message "object too large". - -- - -- If size_t 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 - -- with the additional semantics as described above. - - function Alloc32 (Size : size_t) return System.Address; - -- Equivalent to Alloc except on VMS 64 bit where it invokes - -- 32 bit malloc. - - procedure Free (Ptr : System.Address); - -- This is the low level free routine. It frees a block previously - -- allocated with a call to Alloc. As in the case of Alloc, this - -- call is guaranteed task safe, and aborts are deferred. - -- - -- Note: this is roughly equivalent to the standard C free call - -- with the additional semantics as described above. - - function Realloc - (Ptr : System.Address; - Size : size_t) return System.Address; - -- This is the low level reallocation routine. It takes an existing - -- block address returned by a previous call to Alloc or Realloc, - -- and reallocates the block. The size can either be increased or - -- decreased. If possible the reallocation is done in place, so that - -- the returned result is the same as the value of Ptr on entry. - -- However, it may be necessary to relocate the block to another - -- address, in which case the information is copied to the new - -- block, and the old block is freed. The implementation of this - -- 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 - -- exception is raised with a message "object too large". - -- - -- If size_t 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 - -- with the additional semantics as described above. - - function Realloc32 - (Ptr : System.Address; - Size : size_t) return System.Address; - -- Equivalent to Realloc except on VMS 64 bit where it invokes - -- 32 bit realloc. - -private - - -- The following names are used from the generated compiler code - - pragma Export (C, Alloc, "__gnat_malloc"); - pragma Export (C, Alloc32, "__gnat_malloc32"); - pragma Export (C, Free, "__gnat_free"); - pragma Export (C, Realloc, "__gnat_realloc"); - pragma Export (C, Realloc32, "__gnat_realloc32"); - - function C_malloc32 (Size : size_t) return System.Address; - pragma Import (C, C_malloc32, "_malloc32"); - -- An alias for malloc for allocating 32bit memory on 64bit VMS - - function C_realloc32 - (Ptr : System.Address; - Size : size_t) return System.Address; - pragma Import (C, C_realloc32, "_realloc32"); - -- An alias for realloc for allocating 32bit memory on 64bit VMS - -end System.Memory; diff --git a/main/gcc/ada/s-os_lib.adb b/main/gcc/ada/s-os_lib.adb index 796fe08f5e3..3fad849b87a 100644 --- a/main/gcc/ada/s-os_lib.adb +++ b/main/gcc/ada/s-os_lib.adb @@ -96,8 +96,8 @@ package body System.OS_Lib is Stdout : Boolean); -- Internal routine to implement two Create_Temp_File routines. If Stdout -- is set to True the created descriptor is stdout-compatible, otherwise - -- it might not be depending on the OS (VMS is one example). The first two - -- parameters are as in Create_Temp_File. + -- it might not be depending on the OS. The first two parameters are as + -- in Create_Temp_File. function C_String_Length (S : Address) return Integer; -- Returns the length of C (null-terminated) string at S, or 0 for @@ -279,7 +279,6 @@ package body System.OS_Lib is procedure Close (FD : File_Descriptor) is use CRTL; Discard : constant int := close (int (FD)); - pragma Unreferenced (Discard); begin null; end Close; @@ -417,8 +416,8 @@ package body System.OS_Lib is loop R := Read (From, Buffer (1)'Address, Buf_Size); - -- For VMS, the buffer may not be full. So, we need to try again - -- until there is nothing to read. + -- On some systems, the buffer may not be full. So, we need to try + -- again until there is nothing to read. exit when R = 0; @@ -888,6 +887,26 @@ package body System.OS_Lib is end loop File_Loop; end Create_Temp_File_Internal; + ------------------------- + -- Current_Time_String -- + ------------------------- + + function Current_Time_String return String is + subtype S23 is String (1 .. 23); + -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL + + procedure Current_Time_String (Time : System.Address); + pragma Import (C, Current_Time_String, "__gnat_current_time_string"); + -- Puts current time into Time in above ISO 8601 format + + Result23 : aliased S23; + -- Current time in ISO 8601 format + + begin + Current_Time_String (Result23'Address); + return Result23 (1 .. 19); + end Current_Time_String; + ----------------- -- Delete_File -- ----------------- @@ -1832,6 +1851,7 @@ package body System.OS_Lib is (Host_File : System.Address) return System.Address; pragma Import (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + -- Convert possible foreign file syntax to canonical form The_Name : String (1 .. Name'Length + 1); Canonical_File_Addr : System.Address; @@ -1959,19 +1979,19 @@ package body System.OS_Lib is return ""; end if; - -- First, convert VMS file spec to Unix file spec. - -- If Name is not in VMS syntax, then this is equivalent - -- to put Name at the beginning of Path_Buffer. + -- First, convert possible foreign file spec to Unix file spec. If no + -- conversion is required, all this does is put Name at the beginning + -- of Path_Buffer unchanged. - VMS_Conversion : begin + File_Name_Conversion : begin The_Name (1 .. Name'Length) := Name; The_Name (The_Name'Last) := ASCII.NUL; Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr)); - -- If VMS syntax conversion has failed, return an empty string - -- to indicate the failure. + -- If syntax conversion has failed, return an empty string to + -- indicate the failure. if Canonical_File_Len = 0 then return ""; @@ -1988,7 +2008,7 @@ package body System.OS_Lib is End_Path := Canonical_File_Len; Last := 1; end; - end VMS_Conversion; + end File_Name_Conversion; -- Replace all '/' by Directory Separators (this is for Windows) @@ -2000,12 +2020,7 @@ package body System.OS_Lib is end loop; end if; - -- Resolve directory names for Windows (formerly also VMS) - - -- On VMS, if we have a Unix path such as /temp/..., and TEMP is a - -- logical name, we must not try to resolve this logical name, because - -- it may have multiple equivalences and if resolved we will only - -- get the first one. + -- Resolve directory names for Windows if On_Windows then @@ -2242,6 +2257,33 @@ package body System.OS_Lib is return ""; end Normalize_Pathname; + ----------------- + -- Open_Append -- + ----------------- + + function Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Append, "__gnat_open_append"); + begin + return C_Open_Append (Name, Fmode); + end Open_Append; + + function Open_Append + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Append (C_Name (C_Name'First)'Address, Fmode); + end Open_Append; + --------------- -- Open_Read -- --------------- diff --git a/main/gcc/ada/s-os_lib.ads b/main/gcc/ada/s-os_lib.ads index 50574a932e4..2a24ca29d62 100644 --- a/main/gcc/ada/s-os_lib.ads +++ b/main/gcc/ada/s-os_lib.ads @@ -101,14 +101,14 @@ package System.OS_Lib is --------------------- type OS_Time is private; - -- The OS's notion of time is represented by the private type OS_Time. - -- This is the type returned by the File_Time_Stamp functions to obtain - -- the time stamp of a specified file. Functions and a procedure (modeled - -- after the similar subprograms in package Calendar) are provided for - -- extracting information from a value of this type. Although these are - -- called GM, the intention is not that they provide GMT times in all - -- cases but rather the actual (time-zone independent) time stamp of the - -- file (of course in Unix systems, this *is* in GMT form). + -- The OS's notion of time is represented by the private type OS_Time. This + -- is the type returned by the File_Time_Stamp functions to obtain the time + -- stamp of a specified file. Functions and a procedure (modeled after the + -- similar subprograms in package Calendar) are provided for extracting + -- information from a value of this type. Although these are called GM, the + -- intention in the case of time stamps is not that they provide GMT times + -- in all cases but rather the actual (time-zone independent) time stamp of + -- the file (of course in Unix systems, this *is* in GMT form). Invalid_Time : constant OS_Time; -- A special unique value used to flag an invalid time stamp value @@ -130,7 +130,7 @@ package System.OS_Lib is function GM_Hour (Date : OS_Time) return Hour_Type; function GM_Minute (Date : OS_Time) return Minute_Type; function GM_Second (Date : OS_Time) return Second_Type; - -- Functions to extract information from OS_Time value + -- Functions to extract information from OS_Time value in GMT form function "<" (X, Y : OS_Time) return Boolean; function ">" (X, Y : OS_Time) return Boolean; @@ -160,8 +160,12 @@ package System.OS_Lib is Minute : Minute_Type; Second : Second_Type) return OS_Time; -- Analogous to the Time_Of routine in Ada.Calendar, takes a set of time - -- component parts and returns an OS_Time. Returns Invalid_Time if the - -- creation fails. + -- component parts to be interpreted in the local time zone, and returns + -- an OS_Time. Returns Invalid_Time if the creation fails. + + function Current_Time_String return String; + -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result + -- has bounds 1 .. 19. ---------------- -- File Stuff -- @@ -204,14 +208,22 @@ package System.OS_Lib is function Open_Read (Name : String; Fmode : Mode) return File_Descriptor; - -- Open file Name for reading, returning file descriptor File descriptor - -- returned is Invalid_FD if file cannot be opened. + -- Open file Name for reading, returning its file descriptor. File + -- descriptor returned is Invalid_FD if the file cannot be opened. function Open_Read_Write (Name : String; Fmode : Mode) return File_Descriptor; - -- Open file Name for both reading and writing, returning file descriptor. - -- File descriptor returned is Invalid_FD if file cannot be opened. + -- Open file Name for both reading and writing, returning its file + -- descriptor. File descriptor returned is Invalid_FD if the file + -- cannot be opened. + + function Open_Append + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Opens file Name for appending, returning its file descriptor. File + -- descriptor returned is Invalid_FD if the file cannot be successfully + -- opened. function Create_File (Name : String; @@ -364,7 +376,7 @@ package System.OS_Lib is -- effect of "cp -p" on Unix systems, and None corresponds to the typical -- effect of "cp" on Unix systems. - -- Note: Time_Stamps and Full are not supported on VMS and VxWorks 5 + -- Note: Time_Stamps and Full are not supported on VxWorks 5 procedure Copy_File (Name : String; @@ -380,20 +392,14 @@ package System.OS_Lib is -- True or False indicating if the copy is successful (depending on the -- specified Mode). -- - -- Note: this procedure is only supported to a very limited extent on VMS. - -- The only supported mode is Overwrite, and the only supported value for - -- Preserve is None, resulting in the default action which for Overwrite - -- is to leave attributes unchanged. Furthermore, the copy only works for - -- simple text files. - procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean); -- Copy Source file time stamps (last modification and last access time -- stamps) to Dest file. Source and Dest must be valid filenames, -- furthermore Dest must be writable. Success will be set to True if the -- operation was successful and False otherwise. -- - -- Note: this procedure is not supported on VMS and VxWorks 5. On these - -- platforms, Success is always set to False. + -- Note: this procedure is not supported on VxWorks 5. On this platform, + -- Success is always set to False. procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time); -- Given the name of a file or directory, Name, set the last modification @@ -428,8 +434,15 @@ package System.OS_Lib is -- to the current position (origin = SEEK_CUR), end of file (origin = -- SEEK_END), or start of file (origin = SEEK_SET). + type Large_File_Size is range -2**63 .. 2**63 - 1; + -- Maximum supported size for a file (8 exabytes = 8 million terabytes, + -- should be enough to accomodate all possible needs for quite a while). + function File_Length (FD : File_Descriptor) return Long_Integer; - pragma Import (C, File_Length, "__gnat_file_length"); + pragma Import (C, File_Length, "__gnat_file_length_long"); + + function File_Length64 (FD : File_Descriptor) return Large_File_Size; + pragma Import (C, File_Length64, "__gnat_file_length"); -- Get length of file from file descriptor FD function File_Time_Stamp (Name : String) return OS_Time; @@ -475,17 +488,13 @@ package System.OS_Lib is -- e.g. A is a symbolic link for B, and B is a symbolic link for A), then -- Normalize_Pathname returns an empty string. -- - -- In VMS, if Name follows the VMS syntax file specification, it is first - -- converted into Unix syntax. If the conversion fails, Normalize_Pathname - -- returns an empty string. - -- -- For case-sensitive file systems, the value of Case_Sensitive parameter -- is ignored. For file systems that are not case-sensitive, such as - -- Windows and OpenVMS, if this parameter is set to False, then the file - -- and directory names are folded to lower case. This allows checking - -- whether two files are the same by applying this function to their names - -- and comparing the results. If Case_Sensitive is set to True, this - -- function does not change the casing of file and directory names. + -- Windows, if this parameter is set to False, then the file and directory + -- names are folded to lower case. This allows checking whether two files + -- are the same by applying this function to their names and comparing the + -- results. If Case_Sensitive is set to True, this function does not change + -- the casing of file and directory names. function Is_Absolute_Path (Name : String) return Boolean; -- Returns True if Name is an absolute path name, i.e. it designates a @@ -641,6 +650,10 @@ package System.OS_Lib is (Name : C_File_Name; Fmode : Mode) return File_Descriptor; + function Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + function Create_File (Name : C_File_Name; Fmode : Mode) return File_Descriptor; @@ -885,7 +898,7 @@ package System.OS_Lib is -- On Solaris: fork1, followed in the child process by execv - -- On other Unix-like systems, and on VMS: fork, followed in the child + -- On other Unix-like systems: fork, followed in the child -- process by execv. -- On vxworks, nucleus, and RTX, spawning of processes is not supported @@ -951,7 +964,7 @@ package System.OS_Lib is -- set an explicit null as the value, or to remove the entry, this is -- operating system dependent). Note that any following calls to Spawn -- will pass an environment to the spawned process that includes the - -- changes made by Setenv calls. This procedure is not available on VMS. + -- changes made by Setenv calls. procedure OS_Exit (Status : Integer); pragma No_Return (OS_Exit); diff --git a/main/gcc/ada/s-oscons-tmplt.c b/main/gcc/ada/s-oscons-tmplt.c index 7fef2455ecb..de2b9b988bf 100644 --- a/main/gcc/ada/s-oscons-tmplt.c +++ b/main/gcc/ada/s-oscons-tmplt.c @@ -86,10 +86,17 @@ pragma Style_Checks ("M32766"); ** a number of non-POSIX but useful/required features. **/ -#if defined (__linux__) && !defined (_XOPEN_SOURCE) -/* For Linux, define _XOPEN_SOURCE to get IOV_MAX */ -#define _XOPEN_SOURCE 500 -#endif +#if defined (__linux__) + +/* Define _XOPEN_SOURCE to get IOV_MAX */ +# if !defined (_XOPEN_SOURCE) +# define _XOPEN_SOURCE 500 +# endif + +/* Define _BSD_SOURCE to get CRTSCTS */ +# define _BSD_SOURCE + +#endif /* defined (__linux__) */ /* Include gsocket.h before any system header so it can redefine FD_SETSIZE */ diff --git a/main/gcc/ada/s-osinte-android.adb b/main/gcc/ada/s-osinte-android.adb index 61e1a8a5fc2..df5e19125ec 100644 --- a/main/gcc/ada/s-osinte-android.adb +++ b/main/gcc/ada/s-osinte-android.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1995-2012, AdaCore -- +-- Copyright (C) 1995-2014, 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- -- @@ -38,7 +38,9 @@ pragma Polling (Off); -- This package encapsulates all direct interfaces to OS services -- that are needed by children of System. -with Interfaces.C; use Interfaces.C; +with Interfaces.C; use Interfaces.C; +with Interfaces.C.Extentions; use Interfaces.C.Extentions; + package body System.OS_Interface is ----------------- @@ -88,16 +90,19 @@ package body System.OS_Interface is use Interfaces; - type timeval is array (1 .. 2) of C.long; + type timeval is array (1 .. 3) of C.long; + -- The timeval array is sized to contain long_long sec and long usec. + -- If long_long'Size = long'Size then it will be overly large but that + -- won't effect the implementation since it's not accessed directly. procedure timeval_to_duration (T : not null access timeval; - sec : not null access C.long; + sec : not null access C.Extensions.long_long; usec : not null access C.long); pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); Micro : constant := 10**6; - sec : aliased C.long; + sec : aliased C.Extensions.long_long; usec : aliased C.long; TV : aliased timeval; Result : int; diff --git a/main/gcc/ada/s-osinte-darwin.adb b/main/gcc/ada/s-osinte-darwin.adb index 3bf0bb96d65..e5add8a89bb 100644 --- a/main/gcc/ada/s-osinte-darwin.adb +++ b/main/gcc/ada/s-osinte-darwin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, 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- -- @@ -35,9 +35,11 @@ pragma Polling (Off); -- Turn off polling, we do not want ATC polling to take place during -- tasking operations. It causes infinite loops and other problems. -package body System.OS_Interface is +with Interfaces.C.Extensions; +package body System.OS_Interface is use Interfaces.C; + use Interfaces.C.Extensions; ----------------- -- To_Duration -- @@ -97,16 +99,19 @@ package body System.OS_Interface is use Interfaces; - type timeval is array (1 .. 2) of C.long; + type timeval is array (1 .. 3) of C.long; + -- The timeval array is sized to contain long_long sec and long usec. + -- If long_long'Size = long'Size then it will be overly large but that + -- won't effect the implementation since it's not accessed directly. procedure timeval_to_duration (T : not null access timeval; - sec : not null access C.long; + sec : not null access C.Extensions.long_long; usec : not null access C.long); pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); Micro : constant := 10**6; - sec : aliased C.long; + sec : aliased C.Extensions.long_long; usec : aliased C.long; TV : aliased timeval; Result : int; diff --git a/main/gcc/ada/s-osinte-vms.ads b/main/gcc/ada/s-osinte-vms.ads deleted file mode 100644 index 2b2b135d0e9..00000000000 --- a/main/gcc/ada/s-osinte-vms.ads +++ /dev/null @@ -1,660 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by the tasking run-time (libgnarl). - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; - -with Ada.Unchecked_Conversion; - -with System.Aux_DEC; - -package System.OS_Interface is - pragma Preelaborate; - - -- pragma Linker_Options ("--for-linker=/threads_enable"); - -- Enable upcalls and multiple kernel threads. - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------------------------- - -- Signals (Interrupt IDs) -- - ----------------------------- - - -- Type signal has an arbitrary limit of 31 - - Max_Interrupt : constant := 31; - type Signal is new unsigned range 0 .. Max_Interrupt; - for Signal'Size use unsigned'Size; - - type sigset_t is array (Signal) of Boolean; - pragma Pack (sigset_t); - - -- Interrupt_Number_Type - -- Unsigned long integer denoting the number of an interrupt - - subtype Interrupt_Number_Type is unsigned_long; - - -- OpenVMS system services return values of type Cond_Value_Type - - subtype Cond_Value_Type is unsigned_long; - subtype Short_Cond_Value_Type is unsigned_short; - - type IO_Status_Block_Type is record - Status : Short_Cond_Value_Type; - Count : unsigned_short; - Dev_Info : unsigned_long; - end record; - - type AST_Handler is access procedure (Param : Address); - pragma Convention (C, AST_Handler); - No_AST_Handler : constant AST_Handler := null; - - CMB_M_READONLY : constant := 16#00000001#; - CMB_M_WRITEONLY : constant := 16#00000002#; - AGN_M_READONLY : constant := 16#00000001#; - AGN_M_WRITEONLY : constant := 16#00000002#; - - IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK - IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK - - ---------------- - -- Sys_Assign -- - ---------------- - -- - -- Assign I/O Channel - -- - -- Status = returned status - -- Devnam = address of device name or logical name string - -- descriptor - -- Chan = address of word to receive channel number assigned - -- Acmode = access mode associated with channel - -- Mbxnam = address of mailbox logical name string descriptor, if - -- mailbox associated with device - -- Flags = optional channel flags longword for specifying options - -- for the $ASSIGN operation - -- - - procedure Sys_Assign - (Status : out Cond_Value_Type; - Devnam : String; - Chan : out unsigned_short; - Acmode : unsigned_short := 0; - Mbxnam : String := String'Null_Parameter; - Flags : unsigned_long := 0); - pragma Import (External, Sys_Assign); - pragma Import_Valued_Procedure - (Sys_Assign, "SYS$ASSIGN", - (Cond_Value_Type, String, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Descriptor (s), Reference, - Value, Descriptor (s), Value), - Flags); - - ---------------- - -- Sys_Cantim -- - ---------------- - -- - -- Cancel Timer - -- - -- Status = returned status - -- Reqidt = ID of timer to be cancelled - -- Acmode = Access mode - -- - procedure Sys_Cantim - (Status : out Cond_Value_Type; - Reqidt : Address; - Acmode : unsigned); - pragma Import (External, Sys_Cantim); - pragma Import_Valued_Procedure - (Sys_Cantim, "SYS$CANTIM", - (Cond_Value_Type, Address, unsigned), - (Value, Value, Value)); - - ---------------- - -- Sys_Crembx -- - ---------------- - -- - -- Create mailbox - -- - -- Status = returned status - -- Prmflg = permanent flag - -- Chan = channel - -- Maxmsg = maximum message - -- Bufquo = buufer quote - -- Promsk = protection mast - -- Acmode = access mode - -- Lognam = logical name - -- Flags = flags - -- - procedure Sys_Crembx - (Status : out Cond_Value_Type; - Prmflg : unsigned_char; - Chan : out unsigned_short; - Maxmsg : unsigned_long := 0; - Bufquo : unsigned_long := 0; - Promsk : unsigned_short := 0; - Acmode : unsigned_short := 0; - Lognam : String; - Flags : unsigned_long := 0); - pragma Import (External, Sys_Crembx); - pragma Import_Valued_Procedure - (Sys_Crembx, "SYS$CREMBX", - (Cond_Value_Type, unsigned_char, unsigned_short, - unsigned_long, unsigned_long, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Value, Reference, - Value, Value, Value, - Value, Descriptor (s), Value)); - - ------------- - -- Sys_QIO -- - ------------- - -- - -- Queue I/O - -- - -- Status = Returned status of call - -- EFN = event flag to be set when I/O completes - -- Chan = channel - -- Func = function - -- Iosb = I/O status block - -- Astadr = system trap to be generated when I/O completes - -- Astprm = AST parameter - -- P1-6 = optional parameters - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : unsigned_long := 0; - Chan : unsigned_short; - Func : unsigned_long := 0; - Iosb : out IO_Status_Block_Type; - Astadr : AST_Handler := No_AST_Handler; - Astprm : Address := Null_Address; - P1 : unsigned_long := 0; - P2 : unsigned_long := 0; - P3 : unsigned_long := 0; - P4 : unsigned_long := 0; - P5 : unsigned_long := 0; - P6 : unsigned_long := 0); - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : unsigned_long := 0; - Chan : unsigned_short; - Func : unsigned_long := 0; - Iosb : Address := Null_Address; - Astadr : AST_Handler := No_AST_Handler; - Astprm : Address := Null_Address; - P1 : unsigned_long := 0; - P2 : unsigned_long := 0; - P3 : unsigned_long := 0; - P4 : unsigned_long := 0; - P5 : unsigned_long := 0; - P6 : unsigned_long := 0); - - pragma Import (External, Sys_QIO); - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - IO_Status_Block_Type, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Reference, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - Address, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Value, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - ---------------- - -- Sys_Setimr -- - ---------------- - -- - -- Set Timer - -- - -- Status = Returned status of call - -- EFN = event flag to be set when timer expires - -- Tim = expiration time - -- AST = system trap to be generated when timer expires - -- Redidt = returned ID of timer (e.g. to cancel timer) - -- Flags = flags - -- - procedure Sys_Setimr - (Status : out Cond_Value_Type; - EFN : unsigned_long; - Tim : Long_Integer; - AST : AST_Handler; - Reqidt : Address; - Flags : unsigned_long); - pragma Import (External, Sys_Setimr); - pragma Import_Valued_Procedure - (Sys_Setimr, "SYS$SETIMR", - (Cond_Value_Type, unsigned_long, Long_Integer, - AST_Handler, Address, unsigned_long), - (Value, Value, Reference, - Value, Value, Value)); - - Interrupt_ID_0 : constant := 0; - Interrupt_ID_1 : constant := 1; - Interrupt_ID_2 : constant := 2; - Interrupt_ID_3 : constant := 3; - Interrupt_ID_4 : constant := 4; - Interrupt_ID_5 : constant := 5; - Interrupt_ID_6 : constant := 6; - Interrupt_ID_7 : constant := 7; - Interrupt_ID_8 : constant := 8; - Interrupt_ID_9 : constant := 9; - Interrupt_ID_10 : constant := 10; - Interrupt_ID_11 : constant := 11; - Interrupt_ID_12 : constant := 12; - Interrupt_ID_13 : constant := 13; - Interrupt_ID_14 : constant := 14; - Interrupt_ID_15 : constant := 15; - Interrupt_ID_16 : constant := 16; - Interrupt_ID_17 : constant := 17; - Interrupt_ID_18 : constant := 18; - Interrupt_ID_19 : constant := 19; - Interrupt_ID_20 : constant := 20; - Interrupt_ID_21 : constant := 21; - Interrupt_ID_22 : constant := 22; - Interrupt_ID_23 : constant := 23; - Interrupt_ID_24 : constant := 24; - Interrupt_ID_25 : constant := 25; - Interrupt_ID_26 : constant := 26; - Interrupt_ID_27 : constant := 27; - Interrupt_ID_28 : constant := 28; - Interrupt_ID_29 : constant := 29; - Interrupt_ID_30 : constant := 30; - Interrupt_ID_31 : constant := 31; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EINTR : constant := 4; -- Interrupted system call - EAGAIN : constant := 11; -- No more processes - ENOMEM : constant := 12; -- Not enough core - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 3; - SCHED_BG : constant := 4; - SCHED_LFI : constant := 5; - SCHED_LRR : constant := 6; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill); - - function getpid return pid_t; - pragma Import (C, getpid); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - pragma Convention (C, Thread_Body); - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_JOINABLE : constant := 0; - PTHREAD_CREATE_DETACHED : constant := 1; - - PTHREAD_CANCEL_DISABLE : constant := 0; - PTHREAD_CANCEL_ENABLE : constant := 1; - - PTHREAD_CANCEL_DEFERRED : constant := 0; - PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1; - - -- Don't use ERRORCHECK mutexes, they don't work when a thread is not - -- the owner. AST's, at least, unlock others threads mutexes. Even - -- if the error is ignored, they don't work. - PTHREAD_MUTEX_NORMAL_NP : constant := 0; - PTHREAD_MUTEX_RECURSIVE_NP : constant := 1; - PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2; - - PTHREAD_INHERIT_SCHED : constant := 0; - PTHREAD_EXPLICIT_SCHED : constant := 1; - - function pthread_cancel (thread : pthread_t) return int; - pragma Import (C, pthread_cancel, "PTHREAD_CANCEL"); - - procedure pthread_testcancel; - pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL"); - - function pthread_setcancelstate - (newstate : int; oldstate : access int) return int; - pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE"); - - function pthread_setcanceltype - (newtype : int; oldtype : access int) return int; - pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function pthread_lock_global_np return int; - pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP"); - - function pthread_unlock_global_np return int; - pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY"); - - function pthread_mutexattr_settype_np - (attr : access pthread_mutexattr_t; - mutextype : int) return int; - pragma Import (C, pthread_mutexattr_settype_np, - "PTHREAD_MUTEXATTR_SETTYPE_NP"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK"); - - function pthread_mutex_setname_np - (attr : access pthread_mutex_t; - name : System.Address; - mbz : System.Address) return int; - pragma Import (C, pthread_mutex_setname_np, "PTHREAD_MUTEX_SETNAME_NP"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL"); - - function pthread_cond_signal_int_np - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal_int_np, - "PTHREAD_COND_SIGNAL_INT_NP"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol, - "PTHREAD_MUTEXATTR_SETPROTOCOL"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - for struct_sched_param'Size use 8 * 4; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched, - "PTHREAD_ATTR_SETINHERITSCHED"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, - "PTHREAD_ATTR_SETSCHEDPOLICY"); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM"); - - function pthread_attr_setname_np - (attr : access pthread_attr_t; - name : System.Address; - mbz : System.Address) return int; - pragma Import (C, pthread_attr_setname_np, "PTHREAD_ATTR_SETNAME_NP"); - - function sched_yield return int; - - -------------------------- - -- P1003.1c Section 16 -- - -------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate, - "PTHREAD_ATTR_SETDETACHSTATE"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "PTHREAD_CREATE"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "PTHREAD_EXIT"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "PTHREAD_SELF"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC"); - - type destructor_pointer is access procedure (arg : System.Address); - pragma Convention (C, destructor_pointer); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE"); - -private - - type pid_t is new int; - - type pthreadLongAddr_p is mod 2 ** Long_Integer'Size; - - type pthreadLongAddr_t is mod 2 ** Long_Integer'Size; - type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size; - - type pthreadLongString_t is mod 2 ** Long_Integer'Size; - - type pthreadLongUint_t is mod 2 ** Long_Integer'Size; - type pthreadLongUint_array is array (Natural range <>) - of pthreadLongUint_t; - - type pthread_t is mod 2 ** Long_Integer'Size; - - type pthread_cond_t is record - state : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_t_ptr; - end record; - for pthread_cond_t'Size use 8 * 32; - pragma Convention (C, pthread_cond_t); - - type pthread_attr_t is record - valid : long; - name : pthreadLongString_t; - arg : pthreadLongUint_t; - reserved : pthreadLongUint_array (0 .. 18); - end record; - for pthread_attr_t'Size use 8 * 176; - pragma Convention (C, pthread_attr_t); - - type pthread_mutex_t is record - lock : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_p; - owner : unsigned; - depth : unsigned; - end record; - for pthread_mutex_t'Size use 8 * 40; - pragma Convention (C, pthread_mutex_t); - - type pthread_mutexattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 14); - end record; - for pthread_mutexattr_t'Size use 8 * 128; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_condattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 12); - end record; - for pthread_condattr_t'Size use 8 * 112; - pragma Convention (C, pthread_condattr_t); - - type pthread_key_t is new unsigned; - - pragma Inline (pthread_self); - -end System.OS_Interface; diff --git a/main/gcc/ada/s-osprim-mingw.adb b/main/gcc/ada/s-osprim-mingw.adb index a2c466406c4..f8a41dd509c 100644 --- a/main/gcc/ada/s-osprim-mingw.adb +++ b/main/gcc/ada/s-osprim-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, 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- -- @@ -87,15 +87,15 @@ package body System.OS_Primitives is -- the base data for the changes to get undetected. type Signature_Type is mod 2**32; - Signature : Signature_Type := 0; + Signature : Signature_Type := 0; pragma Atomic (Signature); procedure Get_Base_Time (Data : out Clock_Data); -- Retrieve the base time and base ticks. These values will be used by -- clock to compute the current time by adding to it a fraction of the - -- performance counter. This is for the implementation of a - -- high-resolution clock. Note that this routine does not change the base - -- monotonic values used by the monotonic clock. + -- performance counter. This is for the implementation of a high-resolution + -- clock. Note that this routine does not change the base monotonic values + -- used by the monotonic clock. ----------- -- Clock -- diff --git a/main/gcc/ada/s-osprim-posix.adb b/main/gcc/ada/s-osprim-posix.adb index e03a132c8a3..04aece75e05 100644 --- a/main/gcc/ada/s-osprim-posix.adb +++ b/main/gcc/ada/s-osprim-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, 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- -- @@ -54,16 +54,21 @@ package body System.OS_Primitives is ----------- function Clock return Duration is - type timeval is array (1 .. 2) of Long_Integer; + + type timeval is array (1 .. 3) of Long_Integer; + -- The timeval array is sized to contain Long_Long_Integer sec and + -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then + -- it will be overly large but that will not effect the implementation + -- since it is not accessed directly. procedure timeval_to_duration (T : not null access timeval; - sec : not null access Long_Integer; + sec : not null access Long_Long_Integer; usec : not null access Long_Integer); pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); Micro : constant := 10**6; - sec : aliased Long_Integer; + sec : aliased Long_Long_Integer; usec : aliased Long_Integer; TV : aliased timeval; Result : Integer; diff --git a/main/gcc/ada/s-osprim-vms.adb b/main/gcc/ada/s-osprim-vms.adb deleted file mode 100644 index 5fa499bd13f..00000000000 --- a/main/gcc/ada/s-osprim-vms.adb +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2012, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS/Alpha version of this file - -with System.Aux_DEC; - -package body System.OS_Primitives is - - -------------------------------------- - -- Local functions and declarations -- - -------------------------------------- - - function Get_GMToff return Integer; - pragma Import (C, Get_GMToff, "get_gmtoff"); - -- Get the offset from GMT for this timezone - - function VMS_Epoch_Offset return Long_Integer; - pragma Inline (VMS_Epoch_Offset); - -- The offset between the Unix Epoch and the VMS Epoch - - subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword; - -- Condition Value return type - - ---------------------- - -- VMS_Epoch_Offset -- - ---------------------- - - function VMS_Epoch_Offset return Long_Integer is - begin - return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff)); - end VMS_Epoch_Offset; - - ---------------- - -- Sys_Schdwk -- - ---------------- - -- - -- Schedule Wakeup - -- - -- status = returned status - -- pidadr = address of process id to be woken up - -- prcnam = name of process to be woken up - -- daytim = time to wake up - -- reptim = repetition interval of wakeup calls - -- - - procedure Sys_Schdwk - ( - Status : out Cond_Value_Type; - Pidadr : Address := Null_Address; - Prcnam : String := String'Null_Parameter; - Daytim : Long_Integer; - Reptim : Long_Integer := Long_Integer'Null_Parameter - ); - - pragma Import (External, Sys_Schdwk); - -- VMS system call to schedule a wakeup event - pragma Import_Valued_Procedure - (Sys_Schdwk, "SYS$SCHDWK", - (Cond_Value_Type, Address, String, Long_Integer, Long_Integer), - (Value, Value, Descriptor (S), Reference, Reference) - ); - - ---------------- - -- Sys_Gettim -- - ---------------- - -- - -- Get System Time - -- - -- status = returned status - -- tim = current system time - -- - - procedure Sys_Gettim - ( - Status : out Cond_Value_Type; - Tim : out OS_Time - ); - -- VMS system call to get the current system time - pragma Import (External, Sys_Gettim); - pragma Import_Valued_Procedure - (Sys_Gettim, "SYS$GETTIM", - (Cond_Value_Type, OS_Time), - (Value, Reference) - ); - - --------------- - -- Sys_Hiber -- - --------------- - - -- Hibernate (until woken up) - - -- status = returned status - - procedure Sys_Hiber (Status : out Cond_Value_Type); - -- VMS system call to hibernate the current process - pragma Import (External, Sys_Hiber); - pragma Import_Valued_Procedure - (Sys_Hiber, "SYS$HIBER", - (Cond_Value_Type), - (Value) - ); - - ----------- - -- Clock -- - ----------- - - function OS_Clock return OS_Time is - Status : Cond_Value_Type; - T : OS_Time; - begin - Sys_Gettim (Status, T); - return (T); - end OS_Clock; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - begin - return To_Duration (OS_Clock, Absolute_Calendar); - end Clock; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Sleep_Time : OS_Time; - Status : Cond_Value_Type; - pragma Unreferenced (Status); - - begin - Sleep_Time := To_OS_Time (Time, Mode); - Sys_Schdwk (Status => Status, Daytim => Sleep_Time); - Sys_Hiber (Status); - end Timed_Delay; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : OS_Time; Mode : Integer) return Duration is - pragma Warnings (Off, Mode); - begin - return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; - end To_Duration; - - ---------------- - -- To_OS_Time -- - ---------------- - - function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is - begin - if Mode = Relative then - return -(Long_Integer'Integer_Value (D) / 100); - else - return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset; - end if; - end To_OS_Time; - -end System.OS_Primitives; diff --git a/main/gcc/ada/s-osprim-vms.ads b/main/gcc/ada/s-osprim-vms.ads deleted file mode 100644 index 3b4ed328c8e..00000000000 --- a/main/gcc/ada/s-osprim-vms.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2009, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides low level primitives used to implement clock and --- delays in non tasking applications on Alpha/VMS. - --- The choice of the real clock/delay implementation (depending on whether --- tasking is involved or not) is done via soft links (see s-soflin.ads) - --- NEVER add any dependency to tasking packages here - -package System.OS_Primitives is - pragma Preelaborate; - - subtype OS_Time is Long_Integer; - -- System time on VMS is used for performance reasons. - -- Note that OS_Time is *not* the same as Ada.Calendar.Time, the - -- difference being that relative OS_Time is negative, but relative - -- Calendar.Time is positive. - -- See Ada.Calendar.Delays for more information on VMS Time. - - Max_Sensible_Delay : constant Duration := - Duration'Min (183 * 24 * 60 * 60.0, - Duration'Last); - -- Max of half a year delay, needed to prevent exceptions for large delay - -- values. It seems unlikely that any test will notice this restriction, - -- except in the case of applications setting the clock at run time (see - -- s-tastim.adb). Also note that a larger value might cause problems (e.g - -- overflow, or more likely OS limitation in the primitives used). In the - -- case where half a year is too long (which occurs in high integrity mode - -- with 32-bit words, and possibly on some specific ports of GNAT), - -- Duration'Last is used instead. - - procedure Initialize; - -- Initialize global settings related to this package. This procedure - -- should be called before any other subprograms in this package. Note - -- that this procedure can be called several times. - - function OS_Clock return OS_Time; - -- Returns "absolute" time, represented as an offset - -- relative to "the Epoch", which is Nov 17, 1858 on VMS. - - function Clock return Duration; - pragma Inline (Clock); - -- Returns "absolute" time, represented as an offset relative to "the - -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This - -- implementation is affected by system's clock changes. - - function Monotonic_Clock return Duration; - pragma Inline (Monotonic_Clock); - -- Returns "absolute" time, represented as an offset relative to "the Unix - -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is - -- immune to the system's clock changes. - - Relative : constant := 0; - Absolute_Calendar : constant := 1; - Absolute_RT : constant := 2; - -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies - -- on these values. So any change here must be reflected in corresponding - -- changes in the compiler. - - procedure Timed_Delay (Time : Duration; Mode : Integer); - -- Implements the semantics of the delay statement when no tasking is used - -- in the application. - -- - -- Mode is one of the three values above - -- - -- Time is a relative or absolute duration value, depending on Mode. - -- - -- Note that currently Ada.Real_Time always uses the tasking run time, - -- so this procedure should never be called with Mode set to Absolute_RT. - -- This may change in future or bare board implementations. - - function To_Duration (T : OS_Time; Mode : Integer) return Duration; - -- Convert VMS system time to Duration - -- Mode is one of the three values above - - function To_OS_Time (D : Duration; Mode : Integer) return OS_Time; - -- Convert Duration to VMS system time - -- Mode is one of the three values above - -end System.OS_Primitives; diff --git a/main/gcc/ada/s-pack03.adb b/main/gcc/ada/s-pack03.adb index 3d88c8e5535..b081dc27f8f 100644 --- a/main/gcc/ada/s-pack03.adb +++ b/main/gcc/ada/s-pack03.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_03 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_03 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_03 -- ------------ - function Get_03 (Arr : System.Address; N : Natural) return Bits_03 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_03 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_03 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_03; ------------ -- Set_03 -- ------------ - procedure Set_03 (Arr : System.Address; N : Natural; E : Bits_03) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_03 + (Arr : System.Address; + N : Natural; + E : Bits_03; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_03; end System.Pack_03; diff --git a/main/gcc/ada/s-pack03.ads b/main/gcc/ada/s-pack03.ads index f34428bacde..265246ce8a3 100644 --- a/main/gcc/ada/s-pack03.ads +++ b/main/gcc/ada/s-pack03.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 @@ -- -- ------------------------------------------------------------------------------ --- Handing of packed arrays with Component_Size = 3 +-- Handling of packed arrays with Component_Size = 3 package System.Pack_03 is pragma Preelaborate; @@ -39,11 +39,21 @@ package System.Pack_03 is type Bits_03 is mod 2 ** Bits; for Bits_03'Size use Bits; - function Get_03 (Arr : System.Address; N : Natural) return Bits_03; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_03 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_03 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_03 (Arr : System.Address; N : Natural; E : Bits_03); + procedure Set_03 + (Arr : System.Address; + N : Natural; + E : Bits_03; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack05.adb b/main/gcc/ada/s-pack05.adb index 42af6b1308c..645c3a7df6e 100644 --- a/main/gcc/ada/s-pack05.adb +++ b/main/gcc/ada/s-pack05.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_05 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_05 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_05 -- ------------ - function Get_05 (Arr : System.Address; N : Natural) return Bits_05 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_05 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_05 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_05; ------------ -- Set_05 -- ------------ - procedure Set_05 (Arr : System.Address; N : Natural; E : Bits_05) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_05 + (Arr : System.Address; + N : Natural; + E : Bits_05; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_05; end System.Pack_05; diff --git a/main/gcc/ada/s-pack05.ads b/main/gcc/ada/s-pack05.ads index 761ae4fa3f2..567bdc78551 100644 --- a/main/gcc/ada/s-pack05.ads +++ b/main/gcc/ada/s-pack05.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_05 is type Bits_05 is mod 2 ** Bits; for Bits_05'Size use Bits; - function Get_05 (Arr : System.Address; N : Natural) return Bits_05; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_05 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_05 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_05 (Arr : System.Address; N : Natural; E : Bits_05); + procedure Set_05 + (Arr : System.Address; + N : Natural; + E : Bits_05; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack06.adb b/main/gcc/ada/s-pack06.adb index e2e77b097e2..e467af0631e 100644 --- a/main/gcc/ada/s-pack06.adb +++ b/main/gcc/ada/s-pack06.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_06 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_06 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_06 or SetU_06 is not guaranteed to be aligned. @@ -81,85 +86,165 @@ package body System.Pack_06 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_06 -- ------------ - function Get_06 (Arr : System.Address; N : Natural) return Bits_06 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_06; ------------- -- GetU_06 -- ------------- - function GetU_06 (Arr : System.Address; N : Natural) return Bits_06 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_06; ------------ -- Set_06 -- ------------ - procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure Set_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_06; ------------- -- SetU_06 -- ------------- - procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure SetU_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_06; end System.Pack_06; diff --git a/main/gcc/ada/s-pack06.ads b/main/gcc/ada/s-pack06.ads index 8d907c1b0d1..9db47345386 100644 --- a/main/gcc/ada/s-pack06.ads +++ b/main/gcc/ada/s-pack06.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_06 is type Bits_06 is mod 2 ** Bits; for Bits_06'Size use Bits; - function Get_06 (Arr : System.Address; N : Natural) return Bits_06; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_06 (Arr : System.Address; N : Natural; E : Bits_06); + procedure Set_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_06 (Arr : System.Address; N : Natural) return Bits_06; + function GetU_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_06 (Arr : System.Address; N : Natural; E : Bits_06); + procedure SetU_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack07.adb b/main/gcc/ada/s-pack07.adb index 0dc35e70d5c..45ba8bddd05 100644 --- a/main/gcc/ada/s-pack07.adb +++ b/main/gcc/ada/s-pack07.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_07 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_07 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_07 -- ------------ - function Get_07 (Arr : System.Address; N : Natural) return Bits_07 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_07 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_07 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_07; ------------ -- Set_07 -- ------------ - procedure Set_07 (Arr : System.Address; N : Natural; E : Bits_07) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_07 + (Arr : System.Address; + N : Natural; + E : Bits_07; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_07; end System.Pack_07; diff --git a/main/gcc/ada/s-pack07.ads b/main/gcc/ada/s-pack07.ads index b1b125a1512..a0fa35d298b 100644 --- a/main/gcc/ada/s-pack07.ads +++ b/main/gcc/ada/s-pack07.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_07 is type Bits_07 is mod 2 ** Bits; for Bits_07'Size use Bits; - function Get_07 (Arr : System.Address; N : Natural) return Bits_07; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_07 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_07 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_07 (Arr : System.Address; N : Natural; E : Bits_07); + procedure Set_07 + (Arr : System.Address; + N : Natural; + E : Bits_07; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack09.adb b/main/gcc/ada/s-pack09.adb index 26ac8908775..e0360bbba4f 100644 --- a/main/gcc/ada/s-pack09.adb +++ b/main/gcc/ada/s-pack09.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_09 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_09 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_09 -- ------------ - function Get_09 (Arr : System.Address; N : Natural) return Bits_09 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_09 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_09 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_09; ------------ -- Set_09 -- ------------ - procedure Set_09 (Arr : System.Address; N : Natural; E : Bits_09) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_09 + (Arr : System.Address; + N : Natural; + E : Bits_09; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_09; end System.Pack_09; diff --git a/main/gcc/ada/s-pack09.ads b/main/gcc/ada/s-pack09.ads index be99821f6c2..78defe038b2 100644 --- a/main/gcc/ada/s-pack09.ads +++ b/main/gcc/ada/s-pack09.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_09 is type Bits_09 is mod 2 ** Bits; for Bits_09'Size use Bits; - function Get_09 (Arr : System.Address; N : Natural) return Bits_09; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_09 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_09 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_09 (Arr : System.Address; N : Natural; E : Bits_09); + procedure Set_09 + (Arr : System.Address; + N : Natural; + E : Bits_09; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack10.adb b/main/gcc/ada/s-pack10.adb index 933969db394..402c9fa7867 100644 --- a/main/gcc/ada/s-pack10.adb +++ b/main/gcc/ada/s-pack10.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_10 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_10 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_10 or SetU_10 is not guaranteed to be aligned. @@ -81,85 +86,165 @@ package body System.Pack_10 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_10 -- ------------ - function Get_10 (Arr : System.Address; N : Natural) return Bits_10 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_10; ------------- -- GetU_10 -- ------------- - function GetU_10 (Arr : System.Address; N : Natural) return Bits_10 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_10; ------------ -- Set_10 -- ------------ - procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure Set_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_10; ------------- -- SetU_10 -- ------------- - procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure SetU_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_10; end System.Pack_10; diff --git a/main/gcc/ada/s-pack10.ads b/main/gcc/ada/s-pack10.ads index fcd1d127d25..dc4113efeed 100644 --- a/main/gcc/ada/s-pack10.ads +++ b/main/gcc/ada/s-pack10.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_10 is type Bits_10 is mod 2 ** Bits; for Bits_10'Size use Bits; - function Get_10 (Arr : System.Address; N : Natural) return Bits_10; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_10 (Arr : System.Address; N : Natural; E : Bits_10); + procedure Set_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_10 (Arr : System.Address; N : Natural) return Bits_10; + function GetU_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_10 (Arr : System.Address; N : Natural; E : Bits_10); + procedure SetU_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack11.adb b/main/gcc/ada/s-pack11.adb index 62737fb835d..23edceb12cd 100644 --- a/main/gcc/ada/s-pack11.adb +++ b/main/gcc/ada/s-pack11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_11 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_11 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_11 -- ------------ - function Get_11 (Arr : System.Address; N : Natural) return Bits_11 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_11 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_11 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_11; ------------ -- Set_11 -- ------------ - procedure Set_11 (Arr : System.Address; N : Natural; E : Bits_11) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_11 + (Arr : System.Address; + N : Natural; + E : Bits_11; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_11; end System.Pack_11; diff --git a/main/gcc/ada/s-pack11.ads b/main/gcc/ada/s-pack11.ads index 9c880d26695..e812a0057ea 100644 --- a/main/gcc/ada/s-pack11.ads +++ b/main/gcc/ada/s-pack11.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_11 is type Bits_11 is mod 2 ** Bits; for Bits_11'Size use Bits; - function Get_11 (Arr : System.Address; N : Natural) return Bits_11; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_11 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_11 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_11 (Arr : System.Address; N : Natural; E : Bits_11); + procedure Set_11 + (Arr : System.Address; + N : Natural; + E : Bits_11; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack12.adb b/main/gcc/ada/s-pack12.adb index e12cd66ce32..69b090dc7bb 100644 --- a/main/gcc/ada/s-pack12.adb +++ b/main/gcc/ada/s-pack12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_12 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_12 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_12 or SetU_12 is not guaranteed to be aligned. @@ -81,85 +86,165 @@ package body System.Pack_12 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_12 -- ------------ - function Get_12 (Arr : System.Address; N : Natural) return Bits_12 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_12; ------------- -- GetU_12 -- ------------- - function GetU_12 (Arr : System.Address; N : Natural) return Bits_12 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_12; ------------ -- Set_12 -- ------------ - procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure Set_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_12; ------------- -- SetU_12 -- ------------- - procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure SetU_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_12; end System.Pack_12; diff --git a/main/gcc/ada/s-pack12.ads b/main/gcc/ada/s-pack12.ads index ec8b0732e92..ae0af7e635f 100644 --- a/main/gcc/ada/s-pack12.ads +++ b/main/gcc/ada/s-pack12.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_12 is type Bits_12 is mod 2 ** Bits; for Bits_12'Size use Bits; - function Get_12 (Arr : System.Address; N : Natural) return Bits_12; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_12 (Arr : System.Address; N : Natural; E : Bits_12); + procedure Set_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_12 (Arr : System.Address; N : Natural) return Bits_12; + function GetU_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_12 (Arr : System.Address; N : Natural; E : Bits_12); + procedure SetU_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack13.adb b/main/gcc/ada/s-pack13.adb index d08b5a184d9..0970d694810 100644 --- a/main/gcc/ada/s-pack13.adb +++ b/main/gcc/ada/s-pack13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_13 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_13 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_13 -- ------------ - function Get_13 (Arr : System.Address; N : Natural) return Bits_13 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_13 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_13 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_13; ------------ -- Set_13 -- ------------ - procedure Set_13 (Arr : System.Address; N : Natural; E : Bits_13) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_13 + (Arr : System.Address; + N : Natural; + E : Bits_13; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_13; end System.Pack_13; diff --git a/main/gcc/ada/s-pack13.ads b/main/gcc/ada/s-pack13.ads index a5b6258126b..f58fbf7c61f 100644 --- a/main/gcc/ada/s-pack13.ads +++ b/main/gcc/ada/s-pack13.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_13 is type Bits_13 is mod 2 ** Bits; for Bits_13'Size use Bits; - function Get_13 (Arr : System.Address; N : Natural) return Bits_13; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_13 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_13 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_13 (Arr : System.Address; N : Natural; E : Bits_13); + procedure Set_13 + (Arr : System.Address; + N : Natural; + E : Bits_13; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack14.adb b/main/gcc/ada/s-pack14.adb index 0ef322d18b4..8cae0d7091e 100644 --- a/main/gcc/ada/s-pack14.adb +++ b/main/gcc/ada/s-pack14.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_14 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_14 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_14 or SetU_14 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_14 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_14 -- ------------ - function Get_14 (Arr : System.Address; N : Natural) return Bits_14 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_14; ------------- -- GetU_14 -- ------------- - function GetU_14 (Arr : System.Address; N : Natural) return Bits_14 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_14; ------------ -- Set_14 -- ------------ - procedure Set_14 (Arr : System.Address; N : Natural; E : Bits_14) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_14; ------------- -- SetU_14 -- ------------- - procedure SetU_14 (Arr : System.Address; N : Natural; E : Bits_14) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_14; end System.Pack_14; diff --git a/main/gcc/ada/s-pack14.ads b/main/gcc/ada/s-pack14.ads index 326d2e68c32..72cd783c5a6 100644 --- a/main/gcc/ada/s-pack14.ads +++ b/main/gcc/ada/s-pack14.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 @@ -- -- ------------------------------------------------------------------------------ --- Handing of packed arrays with Component_Size = 14 +-- Handling of packed arrays with Component_Size = 14 package System.Pack_14 is pragma Preelaborate; @@ -39,20 +39,37 @@ package System.Pack_14 is type Bits_14 is mod 2 ** Bits; for Bits_14'Size use Bits; - function Get_14 (Arr : System.Address; N : Natural) return Bits_14; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_14 (Arr : System.Address; N : Natural; E : Bits_14); + procedure Set_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_14 (Arr : System.Address; N : Natural) return Bits_14; + function GetU_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_14 (Arr : System.Address; N : Natural; E : Bits_14); + procedure SetU_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack15.adb b/main/gcc/ada/s-pack15.adb index 7e9c65f07e3..4df1841d667 100644 --- a/main/gcc/ada/s-pack15.adb +++ b/main/gcc/ada/s-pack15.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_15 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_15 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_15 -- ------------ - function Get_15 (Arr : System.Address; N : Natural) return Bits_15 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_15 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_15 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_15; ------------ -- Set_15 -- ------------ - procedure Set_15 (Arr : System.Address; N : Natural; E : Bits_15) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_15 + (Arr : System.Address; + N : Natural; + E : Bits_15; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_15; end System.Pack_15; diff --git a/main/gcc/ada/s-pack15.ads b/main/gcc/ada/s-pack15.ads index 62dc598e377..787ca7ee7e3 100644 --- a/main/gcc/ada/s-pack15.ads +++ b/main/gcc/ada/s-pack15.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_15 is type Bits_15 is mod 2 ** Bits; for Bits_15'Size use Bits; - function Get_15 (Arr : System.Address; N : Natural) return Bits_15; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_15 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_15 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_15 (Arr : System.Address; N : Natural; E : Bits_15); + procedure Set_15 + (Arr : System.Address; + N : Natural; + E : Bits_15; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack17.adb b/main/gcc/ada/s-pack17.adb index 755dd6b4bd9..0fc493881bb 100644 --- a/main/gcc/ada/s-pack17.adb +++ b/main/gcc/ada/s-pack17.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_17 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_17 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_17 -- ------------ - function Get_17 (Arr : System.Address; N : Natural) return Bits_17 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_17 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_17 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_17; ------------ -- Set_17 -- ------------ - procedure Set_17 (Arr : System.Address; N : Natural; E : Bits_17) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_17 + (Arr : System.Address; + N : Natural; + E : Bits_17; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_17; end System.Pack_17; diff --git a/main/gcc/ada/s-pack17.ads b/main/gcc/ada/s-pack17.ads index a81a696206a..9234b1e5008 100644 --- a/main/gcc/ada/s-pack17.ads +++ b/main/gcc/ada/s-pack17.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_17 is type Bits_17 is mod 2 ** Bits; for Bits_17'Size use Bits; - function Get_17 (Arr : System.Address; N : Natural) return Bits_17; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_17 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_17 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_17 (Arr : System.Address; N : Natural; E : Bits_17); + procedure Set_17 + (Arr : System.Address; + N : Natural; + E : Bits_17; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack18.adb b/main/gcc/ada/s-pack18.adb index feba763cd6d..5e2e33f8602 100644 --- a/main/gcc/ada/s-pack18.adb +++ b/main/gcc/ada/s-pack18.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_18 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_18 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_18 or SetU_18 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_18 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_18 -- ------------ - function Get_18 (Arr : System.Address; N : Natural) return Bits_18 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_18; ------------- -- GetU_18 -- ------------- - function GetU_18 (Arr : System.Address; N : Natural) return Bits_18 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_18; ------------ -- Set_18 -- ------------ - procedure Set_18 (Arr : System.Address; N : Natural; E : Bits_18) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_18; ------------- -- SetU_18 -- ------------- - procedure SetU_18 (Arr : System.Address; N : Natural; E : Bits_18) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_18; end System.Pack_18; diff --git a/main/gcc/ada/s-pack18.ads b/main/gcc/ada/s-pack18.ads index 31d6c0b3fc7..051d992cbcc 100644 --- a/main/gcc/ada/s-pack18.ads +++ b/main/gcc/ada/s-pack18.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_18 is type Bits_18 is mod 2 ** Bits; for Bits_18'Size use Bits; - function Get_18 (Arr : System.Address; N : Natural) return Bits_18; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_18 (Arr : System.Address; N : Natural; E : Bits_18); + procedure Set_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_18 (Arr : System.Address; N : Natural) return Bits_18; + function GetU_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_18 (Arr : System.Address; N : Natural; E : Bits_18); + procedure SetU_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack19.adb b/main/gcc/ada/s-pack19.adb index 65d35401757..3a9c2e7f6d2 100644 --- a/main/gcc/ada/s-pack19.adb +++ b/main/gcc/ada/s-pack19.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_19 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_19 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_19 -- ------------ - function Get_19 (Arr : System.Address; N : Natural) return Bits_19 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_19 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_19 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_19; ------------ -- Set_19 -- ------------ - procedure Set_19 (Arr : System.Address; N : Natural; E : Bits_19) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_19 + (Arr : System.Address; + N : Natural; + E : Bits_19; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_19; end System.Pack_19; diff --git a/main/gcc/ada/s-pack19.ads b/main/gcc/ada/s-pack19.ads index 052c216ca6f..03dedb4f426 100644 --- a/main/gcc/ada/s-pack19.ads +++ b/main/gcc/ada/s-pack19.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_19 is type Bits_19 is mod 2 ** Bits; for Bits_19'Size use Bits; - function Get_19 (Arr : System.Address; N : Natural) return Bits_19; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_19 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_19 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_19 (Arr : System.Address; N : Natural; E : Bits_19); + procedure Set_19 + (Arr : System.Address; + N : Natural; + E : Bits_19; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack20.adb b/main/gcc/ada/s-pack20.adb index 6061588ca88..b0b9b4b4300 100644 --- a/main/gcc/ada/s-pack20.adb +++ b/main/gcc/ada/s-pack20.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_20 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_20 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_20 or SetU_20 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_20 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_20 -- ------------ - function Get_20 (Arr : System.Address; N : Natural) return Bits_20 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_20; ------------- -- GetU_20 -- ------------- - function GetU_20 (Arr : System.Address; N : Natural) return Bits_20 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_20; ------------ -- Set_20 -- ------------ - procedure Set_20 (Arr : System.Address; N : Natural; E : Bits_20) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_20; ------------- -- SetU_20 -- ------------- - procedure SetU_20 (Arr : System.Address; N : Natural; E : Bits_20) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_20; end System.Pack_20; diff --git a/main/gcc/ada/s-pack20.ads b/main/gcc/ada/s-pack20.ads index 800d677cd37..e75f828f382 100644 --- a/main/gcc/ada/s-pack20.ads +++ b/main/gcc/ada/s-pack20.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_20 is type Bits_20 is mod 2 ** Bits; for Bits_20'Size use Bits; - function Get_20 (Arr : System.Address; N : Natural) return Bits_20; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_20 (Arr : System.Address; N : Natural; E : Bits_20); + procedure Set_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_20 (Arr : System.Address; N : Natural) return Bits_20; + function GetU_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_20 (Arr : System.Address; N : Natural; E : Bits_20); + procedure SetU_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack21.adb b/main/gcc/ada/s-pack21.adb index 6b78650934f..8357a699a7d 100644 --- a/main/gcc/ada/s-pack21.adb +++ b/main/gcc/ada/s-pack21.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_21 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_21 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_21 -- ------------ - function Get_21 (Arr : System.Address; N : Natural) return Bits_21 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_21 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_21 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_21; ------------ -- Set_21 -- ------------ - procedure Set_21 (Arr : System.Address; N : Natural; E : Bits_21) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_21 + (Arr : System.Address; + N : Natural; + E : Bits_21; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_21; end System.Pack_21; diff --git a/main/gcc/ada/s-pack21.ads b/main/gcc/ada/s-pack21.ads index a0d5939f0d6..0454df05b48 100644 --- a/main/gcc/ada/s-pack21.ads +++ b/main/gcc/ada/s-pack21.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_21 is type Bits_21 is mod 2 ** Bits; for Bits_21'Size use Bits; - function Get_21 (Arr : System.Address; N : Natural) return Bits_21; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_21 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_21 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_21 (Arr : System.Address; N : Natural; E : Bits_21); + procedure Set_21 + (Arr : System.Address; + N : Natural; + E : Bits_21; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack22.adb b/main/gcc/ada/s-pack22.adb index d0e3cdf7701..ae27d67d53b 100644 --- a/main/gcc/ada/s-pack22.adb +++ b/main/gcc/ada/s-pack22.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_22 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_22 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_22 or SetU_22 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_22 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_22 -- ------------ - function Get_22 (Arr : System.Address; N : Natural) return Bits_22 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_22; ------------- -- GetU_22 -- ------------- - function GetU_22 (Arr : System.Address; N : Natural) return Bits_22 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_22; ------------ -- Set_22 -- ------------ - procedure Set_22 (Arr : System.Address; N : Natural; E : Bits_22) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_22; ------------- -- SetU_22 -- ------------- - procedure SetU_22 (Arr : System.Address; N : Natural; E : Bits_22) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_22; end System.Pack_22; diff --git a/main/gcc/ada/s-pack22.ads b/main/gcc/ada/s-pack22.ads index d4f1de78dfa..7504ba8b83d 100644 --- a/main/gcc/ada/s-pack22.ads +++ b/main/gcc/ada/s-pack22.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_22 is type Bits_22 is mod 2 ** Bits; for Bits_22'Size use Bits; - function Get_22 (Arr : System.Address; N : Natural) return Bits_22; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_22 (Arr : System.Address; N : Natural; E : Bits_22); + procedure Set_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_22 (Arr : System.Address; N : Natural) return Bits_22; + function GetU_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_22 (Arr : System.Address; N : Natural; E : Bits_22); + procedure SetU_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack23.adb b/main/gcc/ada/s-pack23.adb index ba14b3bfd0f..85f4af96a76 100644 --- a/main/gcc/ada/s-pack23.adb +++ b/main/gcc/ada/s-pack23.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_23 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_23 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_23 -- ------------ - function Get_23 (Arr : System.Address; N : Natural) return Bits_23 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_23 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_23 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_23; ------------ -- Set_23 -- ------------ - procedure Set_23 (Arr : System.Address; N : Natural; E : Bits_23) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_23 + (Arr : System.Address; + N : Natural; + E : Bits_23; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_23; end System.Pack_23; diff --git a/main/gcc/ada/s-pack23.ads b/main/gcc/ada/s-pack23.ads index eaa968ecea2..9057453c1b2 100644 --- a/main/gcc/ada/s-pack23.ads +++ b/main/gcc/ada/s-pack23.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_23 is type Bits_23 is mod 2 ** Bits; for Bits_23'Size use Bits; - function Get_23 (Arr : System.Address; N : Natural) return Bits_23; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_23 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_23 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_23 (Arr : System.Address; N : Natural; E : Bits_23); + procedure Set_23 + (Arr : System.Address; + N : Natural; + E : Bits_23; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack24.adb b/main/gcc/ada/s-pack24.adb index 49695e6233f..96cbabf750c 100644 --- a/main/gcc/ada/s-pack24.adb +++ b/main/gcc/ada/s-pack24.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_24 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_24 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_24 or SetU_24 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_24 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_24 -- ------------ - function Get_24 (Arr : System.Address; N : Natural) return Bits_24 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_24; ------------- -- GetU_24 -- ------------- - function GetU_24 (Arr : System.Address; N : Natural) return Bits_24 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_24; ------------ -- Set_24 -- ------------ - procedure Set_24 (Arr : System.Address; N : Natural; E : Bits_24) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_24; ------------- -- SetU_24 -- ------------- - procedure SetU_24 (Arr : System.Address; N : Natural; E : Bits_24) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_24; end System.Pack_24; diff --git a/main/gcc/ada/s-pack24.ads b/main/gcc/ada/s-pack24.ads index 440dc48678b..fde2fa3e666 100644 --- a/main/gcc/ada/s-pack24.ads +++ b/main/gcc/ada/s-pack24.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_24 is type Bits_24 is mod 2 ** Bits; for Bits_24'Size use Bits; - function Get_24 (Arr : System.Address; N : Natural) return Bits_24; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_24 (Arr : System.Address; N : Natural; E : Bits_24); + procedure Set_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_24 (Arr : System.Address; N : Natural) return Bits_24; + function GetU_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_24 (Arr : System.Address; N : Natural; E : Bits_24); + procedure SetU_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack25.adb b/main/gcc/ada/s-pack25.adb index 015d4030510..e3df996ca44 100644 --- a/main/gcc/ada/s-pack25.adb +++ b/main/gcc/ada/s-pack25.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_25 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,47 +71,87 @@ package body System.Pack_25 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_25 -- ------------ - function Get_25 (Arr : System.Address; N : Natural) return Bits_25 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + function Get_25 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_25 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_25; ------------ -- Set_25 -- ------------ - procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); - + procedure Set_25 + (Arr : System.Address; + N : Natural; + E : Bits_25; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_25; end System.Pack_25; diff --git a/main/gcc/ada/s-pack25.ads b/main/gcc/ada/s-pack25.ads index b7f3ebbf7e4..d59beebd4bb 100644 --- a/main/gcc/ada/s-pack25.ads +++ b/main/gcc/ada/s-pack25.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_25 is type Bits_25 is mod 2 ** Bits; for Bits_25'Size use Bits; - function Get_25 (Arr : System.Address; N : Natural) return Bits_25; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_25 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_25 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_25 (Arr : System.Address; N : Natural; E : Bits_25); + procedure Set_25 + (Arr : System.Address; + N : Natural; + E : Bits_25; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack26.adb b/main/gcc/ada/s-pack26.adb index 613558f5367..d7edc149e72 100644 --- a/main/gcc/ada/s-pack26.adb +++ b/main/gcc/ada/s-pack26.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_26 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_26 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_26 or SetU_26 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_26 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_26 -- ------------ - function Get_26 (Arr : System.Address; N : Natural) return Bits_26 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_26; ------------- -- GetU_26 -- ------------- - function GetU_26 (Arr : System.Address; N : Natural) return Bits_26 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_26; ------------ -- Set_26 -- ------------ - procedure Set_26 (Arr : System.Address; N : Natural; E : Bits_26) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_26; ------------- -- SetU_26 -- ------------- - procedure SetU_26 (Arr : System.Address; N : Natural; E : Bits_26) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_26; end System.Pack_26; diff --git a/main/gcc/ada/s-pack26.ads b/main/gcc/ada/s-pack26.ads index d0d56ac4208..979e8927856 100644 --- a/main/gcc/ada/s-pack26.ads +++ b/main/gcc/ada/s-pack26.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_26 is type Bits_26 is mod 2 ** Bits; for Bits_26'Size use Bits; - function Get_26 (Arr : System.Address; N : Natural) return Bits_26; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_26 (Arr : System.Address; N : Natural; E : Bits_26); + procedure Set_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_26 (Arr : System.Address; N : Natural) return Bits_26; + function GetU_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_26 (Arr : System.Address; N : Natural; E : Bits_26); + procedure SetU_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack27.adb b/main/gcc/ada/s-pack27.adb index 7497c098f8e..0a15d878abc 100644 --- a/main/gcc/ada/s-pack27.adb +++ b/main/gcc/ada/s-pack27.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_27 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_27 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_27 -- ------------ - function Get_27 (Arr : System.Address; N : Natural) return Bits_27 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_27 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_27 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_27; ------------ -- Set_27 -- ------------ - procedure Set_27 (Arr : System.Address; N : Natural; E : Bits_27) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_27 + (Arr : System.Address; + N : Natural; + E : Bits_27; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_27; end System.Pack_27; diff --git a/main/gcc/ada/s-pack27.ads b/main/gcc/ada/s-pack27.ads index bfb287e1d4b..da77d5746b6 100644 --- a/main/gcc/ada/s-pack27.ads +++ b/main/gcc/ada/s-pack27.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_27 is type Bits_27 is mod 2 ** Bits; for Bits_27'Size use Bits; - function Get_27 (Arr : System.Address; N : Natural) return Bits_27; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_27 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_27 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_27 (Arr : System.Address; N : Natural; E : Bits_27); + procedure Set_27 + (Arr : System.Address; + N : Natural; + E : Bits_27; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack28.adb b/main/gcc/ada/s-pack28.adb index 1342885baf5..35daf6d56e7 100644 --- a/main/gcc/ada/s-pack28.adb +++ b/main/gcc/ada/s-pack28.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_28 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_28 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_28 or SetU_28 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_28 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_28 -- ------------ - function Get_28 (Arr : System.Address; N : Natural) return Bits_28 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_28; ------------- -- GetU_28 -- ------------- - function GetU_28 (Arr : System.Address; N : Natural) return Bits_28 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_28; ------------ -- Set_28 -- ------------ - procedure Set_28 (Arr : System.Address; N : Natural; E : Bits_28) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_28; ------------- -- SetU_28 -- ------------- - procedure SetU_28 (Arr : System.Address; N : Natural; E : Bits_28) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_28; end System.Pack_28; diff --git a/main/gcc/ada/s-pack28.ads b/main/gcc/ada/s-pack28.ads index 79c1751a48c..996ff25a0fd 100644 --- a/main/gcc/ada/s-pack28.ads +++ b/main/gcc/ada/s-pack28.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_28 is type Bits_28 is mod 2 ** Bits; for Bits_28'Size use Bits; - function Get_28 (Arr : System.Address; N : Natural) return Bits_28; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_28 (Arr : System.Address; N : Natural; E : Bits_28); + procedure Set_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_28 (Arr : System.Address; N : Natural) return Bits_28; + function GetU_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_28 (Arr : System.Address; N : Natural; E : Bits_28); + procedure SetU_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack29.adb b/main/gcc/ada/s-pack29.adb index f0a54c13184..73bc62f36f3 100644 --- a/main/gcc/ada/s-pack29.adb +++ b/main/gcc/ada/s-pack29.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_29 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_29 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_29 -- ------------ - function Get_29 (Arr : System.Address; N : Natural) return Bits_29 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_29 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_29 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_29; ------------ -- Set_29 -- ------------ - procedure Set_29 (Arr : System.Address; N : Natural; E : Bits_29) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_29 + (Arr : System.Address; + N : Natural; + E : Bits_29; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_29; end System.Pack_29; diff --git a/main/gcc/ada/s-pack29.ads b/main/gcc/ada/s-pack29.ads index ea479574a3c..47bcb234a8b 100644 --- a/main/gcc/ada/s-pack29.ads +++ b/main/gcc/ada/s-pack29.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_29 is type Bits_29 is mod 2 ** Bits; for Bits_29'Size use Bits; - function Get_29 (Arr : System.Address; N : Natural) return Bits_29; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_29 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_29 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_29 (Arr : System.Address; N : Natural; E : Bits_29); + procedure Set_29 + (Arr : System.Address; + N : Natural; + E : Bits_29; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack30.adb b/main/gcc/ada/s-pack30.adb index 04eb5b3758a..ceab502f7ca 100644 --- a/main/gcc/ada/s-pack30.adb +++ b/main/gcc/ada/s-pack30.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_30 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_30 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_30 or SetU_30 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_30 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_30 -- ------------ - function Get_30 (Arr : System.Address; N : Natural) return Bits_30 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_30; ------------- -- GetU_30 -- ------------- - function GetU_30 (Arr : System.Address; N : Natural) return Bits_30 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_30; ------------ -- Set_30 -- ------------ - procedure Set_30 (Arr : System.Address; N : Natural; E : Bits_30) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_30; ------------- -- SetU_30 -- ------------- - procedure SetU_30 (Arr : System.Address; N : Natural; E : Bits_30) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_30; end System.Pack_30; diff --git a/main/gcc/ada/s-pack30.ads b/main/gcc/ada/s-pack30.ads index b09addfeb1b..aa8585018f5 100644 --- a/main/gcc/ada/s-pack30.ads +++ b/main/gcc/ada/s-pack30.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_30 is type Bits_30 is mod 2 ** Bits; for Bits_30'Size use Bits; - function Get_30 (Arr : System.Address; N : Natural) return Bits_30; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_30 (Arr : System.Address; N : Natural; E : Bits_30); + procedure Set_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_30 (Arr : System.Address; N : Natural) return Bits_30; + function GetU_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_30 (Arr : System.Address; N : Natural; E : Bits_30); + procedure SetU_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack31.adb b/main/gcc/ada/s-pack31.adb index d723601af2c..d0eada3337d 100644 --- a/main/gcc/ada/s-pack31.adb +++ b/main/gcc/ada/s-pack31.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_31 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_31 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_31 -- ------------ - function Get_31 (Arr : System.Address; N : Natural) return Bits_31 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_31 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_31 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_31; ------------ -- Set_31 -- ------------ - procedure Set_31 (Arr : System.Address; N : Natural; E : Bits_31) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_31 + (Arr : System.Address; + N : Natural; + E : Bits_31; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_31; end System.Pack_31; diff --git a/main/gcc/ada/s-pack31.ads b/main/gcc/ada/s-pack31.ads index 4cd0daf7a91..5667e6fee59 100644 --- a/main/gcc/ada/s-pack31.ads +++ b/main/gcc/ada/s-pack31.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_31 is type Bits_31 is mod 2 ** Bits; for Bits_31'Size use Bits; - function Get_31 (Arr : System.Address; N : Natural) return Bits_31; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_31 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_31 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_31 (Arr : System.Address; N : Natural; E : Bits_31); + procedure Set_31 + (Arr : System.Address; + N : Natural; + E : Bits_31; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack33.adb b/main/gcc/ada/s-pack33.adb index 745d8de0318..0cbbf658d11 100644 --- a/main/gcc/ada/s-pack33.adb +++ b/main/gcc/ada/s-pack33.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_33 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_33 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_33 -- ------------ - function Get_33 (Arr : System.Address; N : Natural) return Bits_33 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_33 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_33 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_33; ------------ -- Set_33 -- ------------ - procedure Set_33 (Arr : System.Address; N : Natural; E : Bits_33) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_33 + (Arr : System.Address; + N : Natural; + E : Bits_33; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_33; end System.Pack_33; diff --git a/main/gcc/ada/s-pack33.ads b/main/gcc/ada/s-pack33.ads index a0dc085d558..085298b10e6 100644 --- a/main/gcc/ada/s-pack33.ads +++ b/main/gcc/ada/s-pack33.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_33 is type Bits_33 is mod 2 ** Bits; for Bits_33'Size use Bits; - function Get_33 (Arr : System.Address; N : Natural) return Bits_33; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_33 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_33 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_33 (Arr : System.Address; N : Natural; E : Bits_33); + procedure Set_33 + (Arr : System.Address; + N : Natural; + E : Bits_33; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack34.adb b/main/gcc/ada/s-pack34.adb index 8beafa918a2..b97c63d0689 100644 --- a/main/gcc/ada/s-pack34.adb +++ b/main/gcc/ada/s-pack34.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_34 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_34 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_34 or SetU_34 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_34 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_34 -- ------------ - function Get_34 (Arr : System.Address; N : Natural) return Bits_34 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_34; ------------- -- GetU_34 -- ------------- - function GetU_34 (Arr : System.Address; N : Natural) return Bits_34 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_34; ------------ -- Set_34 -- ------------ - procedure Set_34 (Arr : System.Address; N : Natural; E : Bits_34) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_34; ------------- -- SetU_34 -- ------------- - procedure SetU_34 (Arr : System.Address; N : Natural; E : Bits_34) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_34; end System.Pack_34; diff --git a/main/gcc/ada/s-pack34.ads b/main/gcc/ada/s-pack34.ads index 26dbc98740a..668f8066cd8 100644 --- a/main/gcc/ada/s-pack34.ads +++ b/main/gcc/ada/s-pack34.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_34 is type Bits_34 is mod 2 ** Bits; for Bits_34'Size use Bits; - function Get_34 (Arr : System.Address; N : Natural) return Bits_34; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_34 (Arr : System.Address; N : Natural; E : Bits_34); + procedure Set_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_34 (Arr : System.Address; N : Natural) return Bits_34; + function GetU_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_34 (Arr : System.Address; N : Natural; E : Bits_34); + procedure SetU_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack35.adb b/main/gcc/ada/s-pack35.adb index 009e66707bf..98bbd8586c7 100644 --- a/main/gcc/ada/s-pack35.adb +++ b/main/gcc/ada/s-pack35.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_35 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_35 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_35 -- ------------ - function Get_35 (Arr : System.Address; N : Natural) return Bits_35 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_35 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_35 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_35; ------------ -- Set_35 -- ------------ - procedure Set_35 (Arr : System.Address; N : Natural; E : Bits_35) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_35 + (Arr : System.Address; + N : Natural; + E : Bits_35; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_35; end System.Pack_35; diff --git a/main/gcc/ada/s-pack35.ads b/main/gcc/ada/s-pack35.ads index 17283a95498..a1e8e0c3c9d 100644 --- a/main/gcc/ada/s-pack35.ads +++ b/main/gcc/ada/s-pack35.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_35 is type Bits_35 is mod 2 ** Bits; for Bits_35'Size use Bits; - function Get_35 (Arr : System.Address; N : Natural) return Bits_35; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_35 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_35 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_35 (Arr : System.Address; N : Natural; E : Bits_35); + procedure Set_35 + (Arr : System.Address; + N : Natural; + E : Bits_35; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack36.adb b/main/gcc/ada/s-pack36.adb index bfd3e55ef30..9303a508487 100644 --- a/main/gcc/ada/s-pack36.adb +++ b/main/gcc/ada/s-pack36.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_36 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_36 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_36 or SetU_36 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_36 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_36 -- ------------ - function Get_36 (Arr : System.Address; N : Natural) return Bits_36 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_36; ------------- -- GetU_36 -- ------------- - function GetU_36 (Arr : System.Address; N : Natural) return Bits_36 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_36; ------------ -- Set_36 -- ------------ - procedure Set_36 (Arr : System.Address; N : Natural; E : Bits_36) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_36; ------------- -- SetU_36 -- ------------- - procedure SetU_36 (Arr : System.Address; N : Natural; E : Bits_36) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_36; end System.Pack_36; diff --git a/main/gcc/ada/s-pack36.ads b/main/gcc/ada/s-pack36.ads index 17633fad10e..456c7fa967c 100644 --- a/main/gcc/ada/s-pack36.ads +++ b/main/gcc/ada/s-pack36.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_36 is type Bits_36 is mod 2 ** Bits; for Bits_36'Size use Bits; - function Get_36 (Arr : System.Address; N : Natural) return Bits_36; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_36 (Arr : System.Address; N : Natural; E : Bits_36); + procedure Set_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_36 (Arr : System.Address; N : Natural) return Bits_36; + function GetU_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_36 (Arr : System.Address; N : Natural; E : Bits_36); + procedure SetU_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack37.adb b/main/gcc/ada/s-pack37.adb index 374ecdefaea..ec4a21ac77d 100644 --- a/main/gcc/ada/s-pack37.adb +++ b/main/gcc/ada/s-pack37.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_37 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_37 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_37 -- ------------ - function Get_37 (Arr : System.Address; N : Natural) return Bits_37 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_37 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_37 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_37; ------------ -- Set_37 -- ------------ - procedure Set_37 (Arr : System.Address; N : Natural; E : Bits_37) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_37 + (Arr : System.Address; + N : Natural; + E : Bits_37; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_37; end System.Pack_37; diff --git a/main/gcc/ada/s-pack37.ads b/main/gcc/ada/s-pack37.ads index baa44c6fa60..8b8084346be 100644 --- a/main/gcc/ada/s-pack37.ads +++ b/main/gcc/ada/s-pack37.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_37 is type Bits_37 is mod 2 ** Bits; for Bits_37'Size use Bits; - function Get_37 (Arr : System.Address; N : Natural) return Bits_37; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_37 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_37 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_37 (Arr : System.Address; N : Natural; E : Bits_37); + procedure Set_37 + (Arr : System.Address; + N : Natural; + E : Bits_37; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack38.adb b/main/gcc/ada/s-pack38.adb index 90cf4c43019..b12166ebfc9 100644 --- a/main/gcc/ada/s-pack38.adb +++ b/main/gcc/ada/s-pack38.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_38 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_38 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_38 or SetU_38 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_38 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_38 -- ------------ - function Get_38 (Arr : System.Address; N : Natural) return Bits_38 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_38; ------------- -- GetU_38 -- ------------- - function GetU_38 (Arr : System.Address; N : Natural) return Bits_38 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_38; ------------ -- Set_38 -- ------------ - procedure Set_38 (Arr : System.Address; N : Natural; E : Bits_38) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_38; ------------- -- SetU_38 -- ------------- - procedure SetU_38 (Arr : System.Address; N : Natural; E : Bits_38) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_38; end System.Pack_38; diff --git a/main/gcc/ada/s-pack38.ads b/main/gcc/ada/s-pack38.ads index b246eec7abb..f2a98891c0b 100644 --- a/main/gcc/ada/s-pack38.ads +++ b/main/gcc/ada/s-pack38.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_38 is type Bits_38 is mod 2 ** Bits; for Bits_38'Size use Bits; - function Get_38 (Arr : System.Address; N : Natural) return Bits_38; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_38 (Arr : System.Address; N : Natural; E : Bits_38); + procedure Set_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_38 (Arr : System.Address; N : Natural) return Bits_38; + function GetU_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_38 (Arr : System.Address; N : Natural; E : Bits_38); + procedure SetU_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack39.adb b/main/gcc/ada/s-pack39.adb index 25831911388..85c942a6414 100644 --- a/main/gcc/ada/s-pack39.adb +++ b/main/gcc/ada/s-pack39.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_39 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_39 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_39 -- ------------ - function Get_39 (Arr : System.Address; N : Natural) return Bits_39 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_39 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_39 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_39; ------------ -- Set_39 -- ------------ - procedure Set_39 (Arr : System.Address; N : Natural; E : Bits_39) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_39 + (Arr : System.Address; + N : Natural; + E : Bits_39; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_39; end System.Pack_39; diff --git a/main/gcc/ada/s-pack39.ads b/main/gcc/ada/s-pack39.ads index 90c4eaabad0..8ba083db4df 100644 --- a/main/gcc/ada/s-pack39.ads +++ b/main/gcc/ada/s-pack39.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_39 is type Bits_39 is mod 2 ** Bits; for Bits_39'Size use Bits; - function Get_39 (Arr : System.Address; N : Natural) return Bits_39; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_39 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_39 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_39 (Arr : System.Address; N : Natural; E : Bits_39); + procedure Set_39 + (Arr : System.Address; + N : Natural; + E : Bits_39; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack40.adb b/main/gcc/ada/s-pack40.adb index 72676312066..993fc95dce7 100644 --- a/main/gcc/ada/s-pack40.adb +++ b/main/gcc/ada/s-pack40.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_40 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_40 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_40 or SetU_40 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_40 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_40 -- ------------ - function Get_40 (Arr : System.Address; N : Natural) return Bits_40 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_40; ------------- -- GetU_40 -- ------------- - function GetU_40 (Arr : System.Address; N : Natural) return Bits_40 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_40; ------------ -- Set_40 -- ------------ - procedure Set_40 (Arr : System.Address; N : Natural; E : Bits_40) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_40; ------------- -- SetU_40 -- ------------- - procedure SetU_40 (Arr : System.Address; N : Natural; E : Bits_40) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_40; end System.Pack_40; diff --git a/main/gcc/ada/s-pack40.ads b/main/gcc/ada/s-pack40.ads index 9fd948ecf94..1f30ee358ce 100644 --- a/main/gcc/ada/s-pack40.ads +++ b/main/gcc/ada/s-pack40.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_40 is type Bits_40 is mod 2 ** Bits; for Bits_40'Size use Bits; - function Get_40 (Arr : System.Address; N : Natural) return Bits_40; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_40 (Arr : System.Address; N : Natural; E : Bits_40); + procedure Set_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_40 (Arr : System.Address; N : Natural) return Bits_40; + function GetU_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_40 (Arr : System.Address; N : Natural; E : Bits_40); + procedure SetU_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack41.adb b/main/gcc/ada/s-pack41.adb index 7ace3588455..dd580c06fa5 100644 --- a/main/gcc/ada/s-pack41.adb +++ b/main/gcc/ada/s-pack41.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_41 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_41 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_41 -- ------------ - function Get_41 (Arr : System.Address; N : Natural) return Bits_41 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_41 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_41 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_41; ------------ -- Set_41 -- ------------ - procedure Set_41 (Arr : System.Address; N : Natural; E : Bits_41) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_41 + (Arr : System.Address; + N : Natural; + E : Bits_41; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_41; end System.Pack_41; diff --git a/main/gcc/ada/s-pack41.ads b/main/gcc/ada/s-pack41.ads index 2ff9f511059..8dcae701a0c 100644 --- a/main/gcc/ada/s-pack41.ads +++ b/main/gcc/ada/s-pack41.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_41 is type Bits_41 is mod 2 ** Bits; for Bits_41'Size use Bits; - function Get_41 (Arr : System.Address; N : Natural) return Bits_41; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_41 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_41 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_41 (Arr : System.Address; N : Natural; E : Bits_41); + procedure Set_41 + (Arr : System.Address; + N : Natural; + E : Bits_41; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack42.adb b/main/gcc/ada/s-pack42.adb index 6ba6567b284..bc8285a53d5 100644 --- a/main/gcc/ada/s-pack42.adb +++ b/main/gcc/ada/s-pack42.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_42 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_42 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_42 or SetU_42 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_42 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_42 -- ------------ - function Get_42 (Arr : System.Address; N : Natural) return Bits_42 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_42; ------------- -- GetU_42 -- ------------- - function GetU_42 (Arr : System.Address; N : Natural) return Bits_42 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_42; ------------ -- Set_42 -- ------------ - procedure Set_42 (Arr : System.Address; N : Natural; E : Bits_42) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_42; ------------- -- SetU_42 -- ------------- - procedure SetU_42 (Arr : System.Address; N : Natural; E : Bits_42) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_42; end System.Pack_42; diff --git a/main/gcc/ada/s-pack42.ads b/main/gcc/ada/s-pack42.ads index a0740b26592..73872fd1dd2 100644 --- a/main/gcc/ada/s-pack42.ads +++ b/main/gcc/ada/s-pack42.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_42 is type Bits_42 is mod 2 ** Bits; for Bits_42'Size use Bits; - function Get_42 (Arr : System.Address; N : Natural) return Bits_42; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_42 (Arr : System.Address; N : Natural; E : Bits_42); + procedure Set_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_42 (Arr : System.Address; N : Natural) return Bits_42; + function GetU_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_42 (Arr : System.Address; N : Natural; E : Bits_42); + procedure SetU_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack43.adb b/main/gcc/ada/s-pack43.adb index 7979fb13a91..509cb006ef7 100644 --- a/main/gcc/ada/s-pack43.adb +++ b/main/gcc/ada/s-pack43.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_43 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_43 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_43 -- ------------ - function Get_43 (Arr : System.Address; N : Natural) return Bits_43 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_43 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_43 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_43; ------------ -- Set_43 -- ------------ - procedure Set_43 (Arr : System.Address; N : Natural; E : Bits_43) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_43 + (Arr : System.Address; + N : Natural; + E : Bits_43; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_43; end System.Pack_43; diff --git a/main/gcc/ada/s-pack43.ads b/main/gcc/ada/s-pack43.ads index 99202f2c83a..f82678f6efd 100644 --- a/main/gcc/ada/s-pack43.ads +++ b/main/gcc/ada/s-pack43.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_43 is type Bits_43 is mod 2 ** Bits; for Bits_43'Size use Bits; - function Get_43 (Arr : System.Address; N : Natural) return Bits_43; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_43 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_43 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_43 (Arr : System.Address; N : Natural; E : Bits_43); + procedure Set_43 + (Arr : System.Address; + N : Natural; + E : Bits_43; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack44.adb b/main/gcc/ada/s-pack44.adb index a3f7f001b00..f7fe185573a 100644 --- a/main/gcc/ada/s-pack44.adb +++ b/main/gcc/ada/s-pack44.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_44 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_44 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_44 or SetU_44 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_44 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_44 -- ------------ - function Get_44 (Arr : System.Address; N : Natural) return Bits_44 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_44; ------------- -- GetU_44 -- ------------- - function GetU_44 (Arr : System.Address; N : Natural) return Bits_44 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_44; ------------ -- Set_44 -- ------------ - procedure Set_44 (Arr : System.Address; N : Natural; E : Bits_44) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_44; ------------- -- SetU_44 -- ------------- - procedure SetU_44 (Arr : System.Address; N : Natural; E : Bits_44) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_44; end System.Pack_44; diff --git a/main/gcc/ada/s-pack44.ads b/main/gcc/ada/s-pack44.ads index d083bf2acbd..89b3f3e747e 100644 --- a/main/gcc/ada/s-pack44.ads +++ b/main/gcc/ada/s-pack44.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_44 is type Bits_44 is mod 2 ** Bits; for Bits_44'Size use Bits; - function Get_44 (Arr : System.Address; N : Natural) return Bits_44; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_44 (Arr : System.Address; N : Natural; E : Bits_44); + procedure Set_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_44 (Arr : System.Address; N : Natural) return Bits_44; + function GetU_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_44 (Arr : System.Address; N : Natural; E : Bits_44); + procedure SetU_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack45.adb b/main/gcc/ada/s-pack45.adb index 4a2ce84afc1..2247312e77a 100644 --- a/main/gcc/ada/s-pack45.adb +++ b/main/gcc/ada/s-pack45.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_45 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_45 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_45 -- ------------ - function Get_45 (Arr : System.Address; N : Natural) return Bits_45 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_45 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_45 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_45; ------------ -- Set_45 -- ------------ - procedure Set_45 (Arr : System.Address; N : Natural; E : Bits_45) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_45 + (Arr : System.Address; + N : Natural; + E : Bits_45; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_45; end System.Pack_45; diff --git a/main/gcc/ada/s-pack45.ads b/main/gcc/ada/s-pack45.ads index 2c9b60b88ce..2340d48fb23 100644 --- a/main/gcc/ada/s-pack45.ads +++ b/main/gcc/ada/s-pack45.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_45 is type Bits_45 is mod 2 ** Bits; for Bits_45'Size use Bits; - function Get_45 (Arr : System.Address; N : Natural) return Bits_45; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_45 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_45 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_45 (Arr : System.Address; N : Natural; E : Bits_45); + procedure Set_45 + (Arr : System.Address; + N : Natural; + E : Bits_45; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack46.adb b/main/gcc/ada/s-pack46.adb index 7df5199e602..c2b45f054df 100644 --- a/main/gcc/ada/s-pack46.adb +++ b/main/gcc/ada/s-pack46.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_46 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_46 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_46 or SetU_46 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_46 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_46 -- ------------ - function Get_46 (Arr : System.Address; N : Natural) return Bits_46 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_46; ------------- -- GetU_46 -- ------------- - function GetU_46 (Arr : System.Address; N : Natural) return Bits_46 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_46; ------------ -- Set_46 -- ------------ - procedure Set_46 (Arr : System.Address; N : Natural; E : Bits_46) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_46; ------------- -- SetU_46 -- ------------- - procedure SetU_46 (Arr : System.Address; N : Natural; E : Bits_46) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_46; end System.Pack_46; diff --git a/main/gcc/ada/s-pack46.ads b/main/gcc/ada/s-pack46.ads index 5cdc6a2a216..6ab8dfe5ccc 100644 --- a/main/gcc/ada/s-pack46.ads +++ b/main/gcc/ada/s-pack46.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_46 is type Bits_46 is mod 2 ** Bits; for Bits_46'Size use Bits; - function Get_46 (Arr : System.Address; N : Natural) return Bits_46; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_46 (Arr : System.Address; N : Natural; E : Bits_46); + procedure Set_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_46 (Arr : System.Address; N : Natural) return Bits_46; + function GetU_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_46 (Arr : System.Address; N : Natural; E : Bits_46); + procedure SetU_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack47.adb b/main/gcc/ada/s-pack47.adb index 1cd3d7f624d..d63e35df574 100644 --- a/main/gcc/ada/s-pack47.adb +++ b/main/gcc/ada/s-pack47.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_47 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_47 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_47 -- ------------ - function Get_47 (Arr : System.Address; N : Natural) return Bits_47 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_47 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_47 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_47; ------------ -- Set_47 -- ------------ - procedure Set_47 (Arr : System.Address; N : Natural; E : Bits_47) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_47 + (Arr : System.Address; + N : Natural; + E : Bits_47; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_47; end System.Pack_47; diff --git a/main/gcc/ada/s-pack47.ads b/main/gcc/ada/s-pack47.ads index c44a251f689..f924965b3eb 100644 --- a/main/gcc/ada/s-pack47.ads +++ b/main/gcc/ada/s-pack47.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_47 is type Bits_47 is mod 2 ** Bits; for Bits_47'Size use Bits; - function Get_47 (Arr : System.Address; N : Natural) return Bits_47; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_47 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_47 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_47 (Arr : System.Address; N : Natural; E : Bits_47); + procedure Set_47 + (Arr : System.Address; + N : Natural; + E : Bits_47; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack48.adb b/main/gcc/ada/s-pack48.adb index 615c2701499..780a15793d5 100644 --- a/main/gcc/ada/s-pack48.adb +++ b/main/gcc/ada/s-pack48.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_48 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_48 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_48 or SetU_48 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_48 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_48 -- ------------ - function Get_48 (Arr : System.Address; N : Natural) return Bits_48 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_48; ------------- -- GetU_48 -- ------------- - function GetU_48 (Arr : System.Address; N : Natural) return Bits_48 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_48; ------------ -- Set_48 -- ------------ - procedure Set_48 (Arr : System.Address; N : Natural; E : Bits_48) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_48; ------------- -- SetU_48 -- ------------- - procedure SetU_48 (Arr : System.Address; N : Natural; E : Bits_48) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_48; end System.Pack_48; diff --git a/main/gcc/ada/s-pack48.ads b/main/gcc/ada/s-pack48.ads index f91b7949f7d..ba1008e68b7 100644 --- a/main/gcc/ada/s-pack48.ads +++ b/main/gcc/ada/s-pack48.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_48 is type Bits_48 is mod 2 ** Bits; for Bits_48'Size use Bits; - function Get_48 (Arr : System.Address; N : Natural) return Bits_48; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_48 (Arr : System.Address; N : Natural; E : Bits_48); + procedure Set_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_48 (Arr : System.Address; N : Natural) return Bits_48; + function GetU_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_48 (Arr : System.Address; N : Natural; E : Bits_48); + procedure SetU_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack49.adb b/main/gcc/ada/s-pack49.adb index 9e912035fb7..a9cad236810 100644 --- a/main/gcc/ada/s-pack49.adb +++ b/main/gcc/ada/s-pack49.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_49 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_49 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_49 -- ------------ - function Get_49 (Arr : System.Address; N : Natural) return Bits_49 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_49 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_49 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_49; ------------ -- Set_49 -- ------------ - procedure Set_49 (Arr : System.Address; N : Natural; E : Bits_49) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_49 + (Arr : System.Address; + N : Natural; + E : Bits_49; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_49; end System.Pack_49; diff --git a/main/gcc/ada/s-pack49.ads b/main/gcc/ada/s-pack49.ads index b0ba1f1827b..649e5502313 100644 --- a/main/gcc/ada/s-pack49.ads +++ b/main/gcc/ada/s-pack49.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_49 is type Bits_49 is mod 2 ** Bits; for Bits_49'Size use Bits; - function Get_49 (Arr : System.Address; N : Natural) return Bits_49; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_49 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_49 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_49 (Arr : System.Address; N : Natural; E : Bits_49); + procedure Set_49 + (Arr : System.Address; + N : Natural; + E : Bits_49; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack50.adb b/main/gcc/ada/s-pack50.adb index fb2dc15c068..7cc04e69dac 100644 --- a/main/gcc/ada/s-pack50.adb +++ b/main/gcc/ada/s-pack50.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_50 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_50 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_50 or SetU_50 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_50 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_50 -- ------------ - function Get_50 (Arr : System.Address; N : Natural) return Bits_50 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_50; ------------- -- GetU_50 -- ------------- - function GetU_50 (Arr : System.Address; N : Natural) return Bits_50 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_50; ------------ -- Set_50 -- ------------ - procedure Set_50 (Arr : System.Address; N : Natural; E : Bits_50) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_50; ------------- -- SetU_50 -- ------------- - procedure SetU_50 (Arr : System.Address; N : Natural; E : Bits_50) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_50; end System.Pack_50; diff --git a/main/gcc/ada/s-pack50.ads b/main/gcc/ada/s-pack50.ads index 1399b66e3c3..699165b49a7 100644 --- a/main/gcc/ada/s-pack50.ads +++ b/main/gcc/ada/s-pack50.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_50 is type Bits_50 is mod 2 ** Bits; for Bits_50'Size use Bits; - function Get_50 (Arr : System.Address; N : Natural) return Bits_50; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_50 (Arr : System.Address; N : Natural; E : Bits_50); + procedure Set_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_50 (Arr : System.Address; N : Natural) return Bits_50; + function GetU_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_50 (Arr : System.Address; N : Natural; E : Bits_50); + procedure SetU_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack51.adb b/main/gcc/ada/s-pack51.adb index f8e4d99a2ab..5617a983ae7 100644 --- a/main/gcc/ada/s-pack51.adb +++ b/main/gcc/ada/s-pack51.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_51 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_51 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_51 -- ------------ - function Get_51 (Arr : System.Address; N : Natural) return Bits_51 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_51 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_51 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_51; ------------ -- Set_51 -- ------------ - procedure Set_51 (Arr : System.Address; N : Natural; E : Bits_51) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_51 + (Arr : System.Address; + N : Natural; + E : Bits_51; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_51; end System.Pack_51; diff --git a/main/gcc/ada/s-pack51.ads b/main/gcc/ada/s-pack51.ads index 8e4316c3dbe..99bdd512267 100644 --- a/main/gcc/ada/s-pack51.ads +++ b/main/gcc/ada/s-pack51.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_51 is type Bits_51 is mod 2 ** Bits; for Bits_51'Size use Bits; - function Get_51 (Arr : System.Address; N : Natural) return Bits_51; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_51 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_51 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_51 (Arr : System.Address; N : Natural; E : Bits_51); + procedure Set_51 + (Arr : System.Address; + N : Natural; + E : Bits_51; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack52.adb b/main/gcc/ada/s-pack52.adb index 6c4fd40580a..5adf132af9e 100644 --- a/main/gcc/ada/s-pack52.adb +++ b/main/gcc/ada/s-pack52.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_52 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_52 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_52 or SetU_52 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_52 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_52 -- ------------ - function Get_52 (Arr : System.Address; N : Natural) return Bits_52 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_52; ------------- -- GetU_52 -- ------------- - function GetU_52 (Arr : System.Address; N : Natural) return Bits_52 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_52; ------------ -- Set_52 -- ------------ - procedure Set_52 (Arr : System.Address; N : Natural; E : Bits_52) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_52; ------------- -- SetU_52 -- ------------- - procedure SetU_52 (Arr : System.Address; N : Natural; E : Bits_52) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_52; end System.Pack_52; diff --git a/main/gcc/ada/s-pack52.ads b/main/gcc/ada/s-pack52.ads index 1342a92600e..fab35eecc5d 100644 --- a/main/gcc/ada/s-pack52.ads +++ b/main/gcc/ada/s-pack52.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_52 is type Bits_52 is mod 2 ** Bits; for Bits_52'Size use Bits; - function Get_52 (Arr : System.Address; N : Natural) return Bits_52; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_52 (Arr : System.Address; N : Natural; E : Bits_52); + procedure Set_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_52 (Arr : System.Address; N : Natural) return Bits_52; + function GetU_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_52 (Arr : System.Address; N : Natural; E : Bits_52); + procedure SetU_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack53.adb b/main/gcc/ada/s-pack53.adb index c19512b17ce..471d1fc1c2c 100644 --- a/main/gcc/ada/s-pack53.adb +++ b/main/gcc/ada/s-pack53.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_53 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_53 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_53 -- ------------ - function Get_53 (Arr : System.Address; N : Natural) return Bits_53 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_53 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_53 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_53; ------------ -- Set_53 -- ------------ - procedure Set_53 (Arr : System.Address; N : Natural; E : Bits_53) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_53 + (Arr : System.Address; + N : Natural; + E : Bits_53; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_53; end System.Pack_53; diff --git a/main/gcc/ada/s-pack53.ads b/main/gcc/ada/s-pack53.ads index e0e56838696..380278c2eef 100644 --- a/main/gcc/ada/s-pack53.ads +++ b/main/gcc/ada/s-pack53.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_53 is type Bits_53 is mod 2 ** Bits; for Bits_53'Size use Bits; - function Get_53 (Arr : System.Address; N : Natural) return Bits_53; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_53 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_53 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_53 (Arr : System.Address; N : Natural; E : Bits_53); + procedure Set_53 + (Arr : System.Address; + N : Natural; + E : Bits_53; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack54.adb b/main/gcc/ada/s-pack54.adb index d21dbc0dfdf..5d0294178e7 100644 --- a/main/gcc/ada/s-pack54.adb +++ b/main/gcc/ada/s-pack54.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_54 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_54 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_54 or SetU_54 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_54 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_54 -- ------------ - function Get_54 (Arr : System.Address; N : Natural) return Bits_54 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_54; ------------- -- GetU_54 -- ------------- - function GetU_54 (Arr : System.Address; N : Natural) return Bits_54 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_54; ------------ -- Set_54 -- ------------ - procedure Set_54 (Arr : System.Address; N : Natural; E : Bits_54) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_54; ------------- -- SetU_54 -- ------------- - procedure SetU_54 (Arr : System.Address; N : Natural; E : Bits_54) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_54; end System.Pack_54; diff --git a/main/gcc/ada/s-pack54.ads b/main/gcc/ada/s-pack54.ads index 448f6dbc5f3..5ee9a886678 100644 --- a/main/gcc/ada/s-pack54.ads +++ b/main/gcc/ada/s-pack54.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_54 is type Bits_54 is mod 2 ** Bits; for Bits_54'Size use Bits; - function Get_54 (Arr : System.Address; N : Natural) return Bits_54; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_54 (Arr : System.Address; N : Natural; E : Bits_54); + procedure Set_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_54 (Arr : System.Address; N : Natural) return Bits_54; + function GetU_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_54 (Arr : System.Address; N : Natural; E : Bits_54); + procedure SetU_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack55.adb b/main/gcc/ada/s-pack55.adb index 378d6f22a4f..be264e1318f 100644 --- a/main/gcc/ada/s-pack55.adb +++ b/main/gcc/ada/s-pack55.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_55 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_55 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_55 -- ------------ - function Get_55 (Arr : System.Address; N : Natural) return Bits_55 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_55 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_55 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_55; ------------ -- Set_55 -- ------------ - procedure Set_55 (Arr : System.Address; N : Natural; E : Bits_55) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_55 + (Arr : System.Address; + N : Natural; + E : Bits_55; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_55; end System.Pack_55; diff --git a/main/gcc/ada/s-pack55.ads b/main/gcc/ada/s-pack55.ads index 00d4d93d99f..8dce9fa7141 100644 --- a/main/gcc/ada/s-pack55.ads +++ b/main/gcc/ada/s-pack55.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_55 is type Bits_55 is mod 2 ** Bits; for Bits_55'Size use Bits; - function Get_55 (Arr : System.Address; N : Natural) return Bits_55; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_55 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_55 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_55 (Arr : System.Address; N : Natural; E : Bits_55); + procedure Set_55 + (Arr : System.Address; + N : Natural; + E : Bits_55; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack56.adb b/main/gcc/ada/s-pack56.adb index b27c408e367..fd34211bf37 100644 --- a/main/gcc/ada/s-pack56.adb +++ b/main/gcc/ada/s-pack56.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_56 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_56 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_56 or SetU_56 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_56 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_56 -- ------------ - function Get_56 (Arr : System.Address; N : Natural) return Bits_56 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_56; ------------- -- GetU_56 -- ------------- - function GetU_56 (Arr : System.Address; N : Natural) return Bits_56 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_56; ------------ -- Set_56 -- ------------ - procedure Set_56 (Arr : System.Address; N : Natural; E : Bits_56) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_56; ------------- -- SetU_56 -- ------------- - procedure SetU_56 (Arr : System.Address; N : Natural; E : Bits_56) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_56; end System.Pack_56; diff --git a/main/gcc/ada/s-pack56.ads b/main/gcc/ada/s-pack56.ads index 27c593c1e66..5e6578bb50c 100644 --- a/main/gcc/ada/s-pack56.ads +++ b/main/gcc/ada/s-pack56.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_56 is type Bits_56 is mod 2 ** Bits; for Bits_56'Size use Bits; - function Get_56 (Arr : System.Address; N : Natural) return Bits_56; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_56 (Arr : System.Address; N : Natural; E : Bits_56); + procedure Set_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_56 (Arr : System.Address; N : Natural) return Bits_56; + function GetU_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_56 (Arr : System.Address; N : Natural; E : Bits_56); + procedure SetU_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack57.adb b/main/gcc/ada/s-pack57.adb index c510baf2b24..b477b2e5589 100644 --- a/main/gcc/ada/s-pack57.adb +++ b/main/gcc/ada/s-pack57.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_57 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_57 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_57 -- ------------ - function Get_57 (Arr : System.Address; N : Natural) return Bits_57 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_57 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_57 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_57; ------------ -- Set_57 -- ------------ - procedure Set_57 (Arr : System.Address; N : Natural; E : Bits_57) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_57 + (Arr : System.Address; + N : Natural; + E : Bits_57; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_57; end System.Pack_57; diff --git a/main/gcc/ada/s-pack57.ads b/main/gcc/ada/s-pack57.ads index 5203deaaab7..aff3c500c33 100644 --- a/main/gcc/ada/s-pack57.ads +++ b/main/gcc/ada/s-pack57.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_57 is type Bits_57 is mod 2 ** Bits; for Bits_57'Size use Bits; - function Get_57 (Arr : System.Address; N : Natural) return Bits_57; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_57 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_57 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_57 (Arr : System.Address; N : Natural; E : Bits_57); + procedure Set_57 + (Arr : System.Address; + N : Natural; + E : Bits_57; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack58.adb b/main/gcc/ada/s-pack58.adb index 067928c6436..1aeb45003fe 100644 --- a/main/gcc/ada/s-pack58.adb +++ b/main/gcc/ada/s-pack58.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_58 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_58 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_58 or SetU_58 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_58 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_58 -- ------------ - function Get_58 (Arr : System.Address; N : Natural) return Bits_58 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_58; ------------- -- GetU_58 -- ------------- - function GetU_58 (Arr : System.Address; N : Natural) return Bits_58 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_58; ------------ -- Set_58 -- ------------ - procedure Set_58 (Arr : System.Address; N : Natural; E : Bits_58) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_58; ------------- -- SetU_58 -- ------------- - procedure SetU_58 (Arr : System.Address; N : Natural; E : Bits_58) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_58; end System.Pack_58; diff --git a/main/gcc/ada/s-pack58.ads b/main/gcc/ada/s-pack58.ads index a7e31c7cc6d..503d990e0e9 100644 --- a/main/gcc/ada/s-pack58.ads +++ b/main/gcc/ada/s-pack58.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_58 is type Bits_58 is mod 2 ** Bits; for Bits_58'Size use Bits; - function Get_58 (Arr : System.Address; N : Natural) return Bits_58; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_58 (Arr : System.Address; N : Natural; E : Bits_58); + procedure Set_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_58 (Arr : System.Address; N : Natural) return Bits_58; + function GetU_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_58 (Arr : System.Address; N : Natural; E : Bits_58); + procedure SetU_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack59.adb b/main/gcc/ada/s-pack59.adb index ea93ebff570..35199ce47bd 100644 --- a/main/gcc/ada/s-pack59.adb +++ b/main/gcc/ada/s-pack59.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_59 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_59 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_59 -- ------------ - function Get_59 (Arr : System.Address; N : Natural) return Bits_59 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_59 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_59 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_59; ------------ -- Set_59 -- ------------ - procedure Set_59 (Arr : System.Address; N : Natural; E : Bits_59) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_59 + (Arr : System.Address; + N : Natural; + E : Bits_59; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_59; end System.Pack_59; diff --git a/main/gcc/ada/s-pack59.ads b/main/gcc/ada/s-pack59.ads index 585ecd9c5bf..2abbbf2efc3 100644 --- a/main/gcc/ada/s-pack59.ads +++ b/main/gcc/ada/s-pack59.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_59 is type Bits_59 is mod 2 ** Bits; for Bits_59'Size use Bits; - function Get_59 (Arr : System.Address; N : Natural) return Bits_59; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_59 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_59 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_59 (Arr : System.Address; N : Natural; E : Bits_59); + procedure Set_59 + (Arr : System.Address; + N : Natural; + E : Bits_59; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack60.adb b/main/gcc/ada/s-pack60.adb index 5ade775071d..e909f71b6a9 100644 --- a/main/gcc/ada/s-pack60.adb +++ b/main/gcc/ada/s-pack60.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_60 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_60 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_60 or SetU_60 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_60 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_60 -- ------------ - function Get_60 (Arr : System.Address; N : Natural) return Bits_60 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_60; ------------- -- GetU_60 -- ------------- - function GetU_60 (Arr : System.Address; N : Natural) return Bits_60 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_60; ------------ -- Set_60 -- ------------ - procedure Set_60 (Arr : System.Address; N : Natural; E : Bits_60) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_60; ------------- -- SetU_60 -- ------------- - procedure SetU_60 (Arr : System.Address; N : Natural; E : Bits_60) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_60; end System.Pack_60; diff --git a/main/gcc/ada/s-pack60.ads b/main/gcc/ada/s-pack60.ads index cee776b7831..bc4886878ed 100644 --- a/main/gcc/ada/s-pack60.ads +++ b/main/gcc/ada/s-pack60.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_60 is type Bits_60 is mod 2 ** Bits; for Bits_60'Size use Bits; - function Get_60 (Arr : System.Address; N : Natural) return Bits_60; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_60 (Arr : System.Address; N : Natural; E : Bits_60); + procedure Set_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_60 (Arr : System.Address; N : Natural) return Bits_60; + function GetU_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_60 (Arr : System.Address; N : Natural; E : Bits_60); + procedure SetU_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack61.adb b/main/gcc/ada/s-pack61.adb index 27f72e4127c..cd29c81294d 100644 --- a/main/gcc/ada/s-pack61.adb +++ b/main/gcc/ada/s-pack61.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_61 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_61 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_61 -- ------------ - function Get_61 (Arr : System.Address; N : Natural) return Bits_61 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_61 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_61 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_61; ------------ -- Set_61 -- ------------ - procedure Set_61 (Arr : System.Address; N : Natural; E : Bits_61) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_61 + (Arr : System.Address; + N : Natural; + E : Bits_61; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_61; end System.Pack_61; diff --git a/main/gcc/ada/s-pack61.ads b/main/gcc/ada/s-pack61.ads index 0d63baefd7d..ac309a230f8 100644 --- a/main/gcc/ada/s-pack61.ads +++ b/main/gcc/ada/s-pack61.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_61 is type Bits_61 is mod 2 ** Bits; for Bits_61'Size use Bits; - function Get_61 (Arr : System.Address; N : Natural) return Bits_61; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_61 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_61 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_61 (Arr : System.Address; N : Natural; E : Bits_61); + procedure Set_61 + (Arr : System.Address; + N : Natural; + E : Bits_61; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-pack62.adb b/main/gcc/ada/s-pack62.adb index faac2115cc2..b13754df5c7 100644 --- a/main/gcc/ada/s-pack62.adb +++ b/main/gcc/ada/s-pack62.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_62 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,8 +71,10 @@ package body System.Pack_62 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; -- The following declarations are for the case where the address -- passed to GetU_62 or SetU_62 is not guaranteed to be aligned. @@ -81,83 +86,165 @@ package body System.Pack_62 is type ClusterU_Ref is access ClusterU; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, ClusterU_Ref); + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; ------------ -- Get_62 -- ------------ - function Get_62 (Arr : System.Address; N : Natural) return Bits_62 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_62; ------------- -- GetU_62 -- ------------- - function GetU_62 (Arr : System.Address; N : Natural) return Bits_62 is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function GetU_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end GetU_62; ------------ -- Set_62 -- ------------ - procedure Set_62 (Arr : System.Address; N : Natural; E : Bits_62) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_62; ------------- -- SetU_62 -- ------------- - procedure SetU_62 (Arr : System.Address; N : Natural; E : Bits_62) is - C : constant ClusterU_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure SetU_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end SetU_62; end System.Pack_62; diff --git a/main/gcc/ada/s-pack62.ads b/main/gcc/ada/s-pack62.ads index 89ad4469a04..b8b19f4a4f1 100644 --- a/main/gcc/ada/s-pack62.ads +++ b/main/gcc/ada/s-pack62.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,20 +39,37 @@ package System.Pack_62 is type Bits_62 is mod 2 ** Bits; for Bits_62'Size use Bits; - function Get_62 (Arr : System.Address; N : Natural) return Bits_62; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_62 (Arr : System.Address; N : Natural; E : Bits_62); + procedure Set_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. - function GetU_62 (Arr : System.Address; N : Natural) return Bits_62; + function GetU_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. This version -- is used when Arr may represent an unaligned address. - procedure SetU_62 (Arr : System.Address; N : Natural; E : Bits_62); + procedure SetU_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. This version -- is used when Arr may represent an unaligned address diff --git a/main/gcc/ada/s-pack63.adb b/main/gcc/ada/s-pack63.adb index c6faee6fbf8..109f914b9b3 100644 --- a/main/gcc/ada/s-pack63.adb +++ b/main/gcc/ada/s-pack63.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 @@ with System.Storage_Elements; with System.Unsigned_Types; -with Ada.Unchecked_Conversion; package body System.Pack_63 is + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + subtype Ofs is System.Storage_Elements.Storage_Offset; subtype Uns is System.Unsigned_Types.Unsigned; subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; @@ -68,45 +71,87 @@ package body System.Pack_63 is type Cluster_Ref is access Cluster; - function To_Ref is new - Ada.Unchecked_Conversion (System.Address, Cluster_Ref); + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; ------------ -- Get_63 -- ------------ - function Get_63 (Arr : System.Address; N : Natural) return Bits_63 is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + function Get_63 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_63 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; end Get_63; ------------ -- Set_63 -- ------------ - procedure Set_63 (Arr : System.Address; N : Natural; E : Bits_63) is - C : constant Cluster_Ref := To_Ref (Arr + Bits * Ofs (Uns (N) / 8)); + procedure Set_63 + (Arr : System.Address; + N : Natural; + E : Bits_63; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; begin - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; end Set_63; end System.Pack_63; diff --git a/main/gcc/ada/s-pack63.ads b/main/gcc/ada/s-pack63.ads index b76eed0efd6..c59678b4cd4 100644 --- a/main/gcc/ada/s-pack63.ads +++ b/main/gcc/ada/s-pack63.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,11 +39,21 @@ package System.Pack_63 is type Bits_63 is mod 2 ** Bits; for Bits_63'Size use Bits; - function Get_63 (Arr : System.Address; N : Natural) return Bits_63; + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_63 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_63 with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is extracted and returned. - procedure Set_63 (Arr : System.Address; N : Natural; E : Bits_63); + procedure Set_63 + (Arr : System.Address; + N : Natural; + E : Bits_63; + Rev_SSO : Boolean) with Inline; -- Arr is the address of the packed array, N is the zero-based -- subscript. This element is set to the given value. diff --git a/main/gcc/ada/s-parame-ae653.ads b/main/gcc/ada/s-parame-ae653.ads index 82a5d31562b..3cf170a4718 100644 --- a/main/gcc/ada/s-parame-ae653.ads +++ b/main/gcc/ada/s-parame-ae653.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,14 +109,12 @@ package System.Parameters is long_bits : constant := Long_Integer'Size; -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. ptr_bits : constant := Standard'Address_Size; subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. + -- Number of bits in Interfaces.C pointers, normally a standard address C_Malloc_Linkname : constant String := "__gnat_malloc"; -- Name of runtime function used to allocate such a pointer @@ -182,9 +180,8 @@ package System.Parameters is -- Task Attributes -- --------------------- - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. + Max_Attribute_Count : constant := 8; + -- Number of task attributes stored in the task control block -------------------- -- Runtime Traces -- diff --git a/main/gcc/ada/s-parame-hpux.ads b/main/gcc/ada/s-parame-hpux.ads index b8511162fff..319195644e5 100644 --- a/main/gcc/ada/s-parame-hpux.ads +++ b/main/gcc/ada/s-parame-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -107,14 +107,12 @@ package System.Parameters is long_bits : constant := Long_Integer'Size; -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. ptr_bits : constant := Standard'Address_Size; subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. + -- Number of bits in Interfaces.C pointers, normally a standard address C_Malloc_Linkname : constant String := "__gnat_malloc"; -- Name of runtime function used to allocate such a pointer @@ -180,9 +178,8 @@ package System.Parameters is -- Task Attributes -- --------------------- - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. + Max_Attribute_Count : constant := 32; + -- Number of task attributes stored in the task control block -------------------- -- Runtime Traces -- diff --git a/main/gcc/ada/s-parame-vms-alpha.ads b/main/gcc/ada/s-parame-vms-alpha.ads deleted file mode 100644 index 359e694d4c5..00000000000 --- a/main/gcc/ada/s-parame-vms-alpha.ads +++ /dev/null @@ -1,216 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS Alpha version - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ptr_bits : constant := 32; - subtype C_Address is System.Address - range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1; - for C_Address'Object_Size use ptr_bits; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. System.Aux_DEC.Short_Address can't be used because of - -- elaboration circularity. - - C_Malloc_Linkname : constant String := "__gnat_malloc32"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := True; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 512; - -- This constant specifies the maximum number of characters to allow in an - -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the - -- default minimum of 200 to allow for the length of chained VMS condition - -- handling messages. - -end System.Parameters; diff --git a/main/gcc/ada/s-parame-vms-ia64.ads b/main/gcc/ada/s-parame-vms-ia64.ads deleted file mode 100644 index 2726f34b2c4..00000000000 --- a/main/gcc/ada/s-parame-vms-ia64.ads +++ /dev/null @@ -1,216 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Integrity OpenVMS version - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ptr_bits : constant := 32; - subtype C_Address is System.Address - range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1; - for C_Address'Object_Size use ptr_bits; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. System.Aux_DEC.Short_Address can't be used because of - -- elaboration circularity. - - C_Malloc_Linkname : constant String := "__gnat_malloc32"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 512; - -- This constant specifies the maximum number of characters to allow in an - -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the - -- default minimum of 200 to allow for the length of chained VMS condition - -- handling messages. - -end System.Parameters; diff --git a/main/gcc/ada/s-parame-vxworks.ads b/main/gcc/ada/s-parame-vxworks.ads index 748e7d81b39..10769cd696c 100644 --- a/main/gcc/ada/s-parame-vxworks.ads +++ b/main/gcc/ada/s-parame-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,14 +109,12 @@ package System.Parameters is long_bits : constant := Long_Integer'Size; -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. ptr_bits : constant := Standard'Address_Size; subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. + -- Number of bits in Interfaces.C pointers, normally a standard address C_Malloc_Linkname : constant String := "__gnat_malloc"; -- Name of runtime function used to allocate such a pointer @@ -182,9 +180,8 @@ package System.Parameters is -- Task Attributes -- --------------------- - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. + Max_Attribute_Count : constant := 16; + -- Number of task attributes stored in the task control block -------------------- -- Runtime Traces -- diff --git a/main/gcc/ada/s-parame.ads b/main/gcc/ada/s-parame.ads index 4ebfc5cd877..2c2a2fadac9 100644 --- a/main/gcc/ada/s-parame.ads +++ b/main/gcc/ada/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,14 +109,12 @@ package System.Parameters is long_bits : constant := Long_Integer'Size; -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. ptr_bits : constant := Standard'Address_Size; subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. + -- Number of bits in Interfaces.C pointers, normally a standard address C_Malloc_Linkname : constant String := "__gnat_malloc"; -- Name of runtime function used to allocate such a pointer @@ -182,9 +180,8 @@ package System.Parameters is -- Task Attributes -- --------------------- - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. + Max_Attribute_Count : constant := 32; + -- Number of task attributes stored in the task control block -------------------- -- Runtime Traces -- diff --git a/main/gcc/ada/s-po32gl.adb b/main/gcc/ada/s-po32gl.adb deleted file mode 100644 index 54acf26bc65..00000000000 --- a/main/gcc/ada/s-po32gl.adb +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ 3 2 _ G L O B A L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Pools; use System.Storage_Pools; -with System.Memory; - -package body System.Pool_32_Global is - - package SSE renames System.Storage_Elements; - - -------------- - -- Allocate -- - -------------- - - overriding procedure Allocate - (Pool : in out Unbounded_No_Reclaim_Pool_32; - Address : out System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - pragma Warnings (Off, Pool); - pragma Warnings (Off, Alignment); - - begin - Address := Memory.Alloc32 (Memory.size_t (Storage_Size)); - - -- The call to Alloc returns an address whose alignment is compatible - -- with the worst case alignment requirement for the machine; thus the - -- Alignment argument can be safely ignored. - - if Address = Null_Address then - raise Storage_Error; - end if; - end Allocate; - - ---------------- - -- Deallocate -- - ---------------- - - overriding procedure Deallocate - (Pool : in out Unbounded_No_Reclaim_Pool_32; - Address : System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - pragma Warnings (Off, Pool); - pragma Warnings (Off, Storage_Size); - pragma Warnings (Off, Alignment); - - begin - Memory.Free (Address); - end Deallocate; - - ------------------ - -- Storage_Size -- - ------------------ - - overriding function Storage_Size - (Pool : Unbounded_No_Reclaim_Pool_32) - return SSE.Storage_Count - is - pragma Warnings (Off, Pool); - - begin - -- The 32 bit heap is limited to 2 GB of memory - - return SSE.Storage_Count (2 ** 31); - end Storage_Size; - -end System.Pool_32_Global; diff --git a/main/gcc/ada/s-po32gl.ads b/main/gcc/ada/s-po32gl.ads deleted file mode 100644 index 578fbec8942..00000000000 --- a/main/gcc/ada/s-po32gl.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ 3 2 _ G L O B A L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Storage pool corresponding to default global storage pool used for types --- designated by a 32 bits access type for which no storage pool is specified. --- This is specific to VMS. - -with System; -with System.Storage_Pools; -with System.Storage_Elements; - -package System.Pool_32_Global is - pragma Elaborate_Body; - -- Needed to ensure that library routines can execute allocators - - -- Allocation strategy: - - -- Call to malloc/free for each Allocate/Deallocate - -- No user specifiable size - -- No automatic reclaim - -- Minimal overhead - - -- Pool simulating the allocation/deallocation strategy used by the - -- compiler for access types globally declared. - - type Unbounded_No_Reclaim_Pool_32 is new - System.Storage_Pools.Root_Storage_Pool with null record; - - overriding function Storage_Size - (Pool : Unbounded_No_Reclaim_Pool_32) - return System.Storage_Elements.Storage_Count; - - overriding procedure Allocate - (Pool : in out Unbounded_No_Reclaim_Pool_32; - Address : out System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - overriding procedure Deallocate - (Pool : in out Unbounded_No_Reclaim_Pool_32; - Address : System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - -- Pool object used by the compiler when implicit Storage Pool objects are - -- explicitly referred to. For instance when writing something like: - -- for T'Storage_Pool use Q'Storage_Pool; - -- and Q'Storage_Pool hasn't been defined explicitly. - - Global_Pool_32_Object : Unbounded_No_Reclaim_Pool_32; - -end System.Pool_32_Global; diff --git a/main/gcc/ada/s-powtab.ads b/main/gcc/ada/s-powtab.ads index ea1820b1324..5a84b50f4c5 100644 --- a/main/gcc/ada/s-powtab.ads +++ b/main/gcc/ada/s-powtab.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-proinf.adb b/main/gcc/ada/s-proinf.adb index 308b207b0d2..1d7e424c92e 100644 --- a/main/gcc/ada/s-proinf.adb +++ b/main/gcc/ada/s-proinf.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-ransee-vms.adb b/main/gcc/ada/s-ransee-vms.adb deleted file mode 100644 index 713edaef79f..00000000000 --- a/main/gcc/ada/s-ransee-vms.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R A N D O M _ S E E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version used on OpenVMS systems, where Clock accuracy is too low for --- RM A.5.2(45). - -with Interfaces; use Interfaces; - -package body System.Random_Seed is - - function Sys_Rpcc_64 return Unsigned_64; - pragma Import (C, Sys_Rpcc_64, "SYS$RPCC_64"); - - -------------- - -- Get_Seed -- - -------------- - - function Get_Seed return Interfaces.Unsigned_64 is - begin - return Sys_Rpcc_64; - end Get_Seed; - -end System.Random_Seed; diff --git a/main/gcc/ada/s-regpat.adb b/main/gcc/ada/s-regpat.adb index d32bb03f06d..d5ef0229e47 100644 --- a/main/gcc/ada/s-regpat.adb +++ b/main/gcc/ada/s-regpat.adb @@ -7,7 +7,7 @@ -- B o d y -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2013, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -410,10 +410,13 @@ package body System.Regpat is procedure Parse (Parenthesized : Boolean; + Capturing : Boolean; Flags : out Expression_Flags; IP : out Pointer); -- Parse regular expression, i.e. main body or parenthesized thing - -- Caller must absorb opening parenthesis. + -- Caller must absorb opening parenthesis. Capturing should be set to + -- True when we have an open parenthesis from which we want the user + -- to extra text. procedure Parse_Branch (Flags : out Expression_Flags; @@ -831,9 +834,10 @@ package body System.Regpat is -- the branches to what follows makes it hard to avoid. procedure Parse - (Parenthesized : Boolean; - Flags : out Expression_Flags; - IP : out Pointer) + (Parenthesized : Boolean; + Capturing : Boolean; + Flags : out Expression_Flags; + IP : out Pointer) is E : String renames Expression; Br, Br2 : Pointer; @@ -847,7 +851,7 @@ package body System.Regpat is -- Make an OPEN node, if parenthesized - if Parenthesized then + if Parenthesized and then Capturing then if Matcher.Paren_Count > Max_Paren_Count then Fail ("too many ()"); end if; @@ -856,7 +860,6 @@ package body System.Regpat is Matcher.Paren_Count := Matcher.Paren_Count + 1; IP := Emit_Node (OPEN); Emit (Character'Val (Par_No)); - else IP := 0; Par_No := 0; @@ -913,14 +916,21 @@ package body System.Regpat is -- Make a closing node, and hook it on the end if Parenthesized then - Ender := Emit_Node (CLOSE); - Emit (Character'Val (Par_No)); + if Capturing then + Ender := Emit_Node (CLOSE); + Emit (Character'Val (Par_No)); + Link_Tail (IP, Ender); + + else + -- Need to keep looking after the closing parenthesis + Ender := Emit_Ptr; + end if; + else Ender := Emit_Node (EOP); + Link_Tail (IP, Ender); end if; - Link_Tail (IP, Ender); - if Have_Branch and then Emit_Ptr <= PM.Size + 1 then -- Hook the tails of the branches to the closing node @@ -945,7 +955,7 @@ package body System.Regpat is elsif Parse_Pos <= Parse_End then if E (Parse_Pos) = ')' then - Fail ("unmatched ()"); + Fail ("unmatched ')'"); else Fail ("junk on end"); -- "Can't happen" end if; @@ -1003,16 +1013,28 @@ package body System.Regpat is New_Flags : Expression_Flags; begin - Parse (True, New_Flags, IP); + if Parse_Pos <= Parse_End - 1 + and then Expression (Parse_Pos) = '?' + and then Expression (Parse_Pos + 1) = ':' + then + Parse_Pos := Parse_Pos + 2; - if IP = 0 then - return; - end if; + -- Non-capturing parenthesis + + Parse (True, False, New_Flags, IP); - Expr_Flags.Has_Width := - Expr_Flags.Has_Width or else New_Flags.Has_Width; - Expr_Flags.SP_Start := - Expr_Flags.SP_Start or else New_Flags.SP_Start; + else + -- Capturing parenthesis + + Parse (True, True, New_Flags, IP); + Expr_Flags.Has_Width := + Expr_Flags.Has_Width or else New_Flags.Has_Width; + Expr_Flags.SP_Start := + Expr_Flags.SP_Start or else New_Flags.SP_Start; + if IP = 0 then + return; + end if; + end if; end; when '|' | ASCII.LF | ')' => @@ -1971,7 +1993,7 @@ package body System.Regpat is -- Start of processing for Compile begin - Parse (False, Expr_Flags, Result); + Parse (False, False, Expr_Flags, Result); if Result = 0 then Fail ("Couldn't compile expression"); diff --git a/main/gcc/ada/s-regpat.ads b/main/gcc/ada/s-regpat.ads index 74e617fcdfb..5c8bf5e1c3c 100644 --- a/main/gcc/ada/s-regpat.ads +++ b/main/gcc/ada/s-regpat.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2010, AdaCore -- +-- Copyright (C) 1996-2014, 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- -- @@ -78,8 +78,10 @@ package System.Regpat is -- ::= [^ range range ...] -- matches any character not listed -- ::= . -- matches any single character -- -- except newlines - -- ::= ( expr ) -- parens used for grouping - -- ::= \ num -- reference to num-th parenthesis + -- ::= ( expr ) -- parenthesis used for grouping + -- ::= (?: expr ) -- non-capturing parenthesis + -- ::= \ num -- reference to num-th capturing + -- parenthesis -- range ::= char - char -- matches chars in given range -- ::= nchr @@ -345,6 +347,9 @@ package System.Regpat is -- N'th parenthesized subexpressions; Matches (0) is for the whole -- expression. -- + -- Non-capturing parenthesis (introduced with (?:...)) can not be + -- retrieved and do not count in the match array index. + -- -- For instance, if your regular expression is: "a((b*)c+)(d+)", then -- 12 3 -- Matches (0) is for "a((b*)c+)(d+)" (the entire expression) diff --git a/main/gcc/ada/s-shasto.ads b/main/gcc/ada/s-shasto.ads index 0ef65cc59f2..51e49e8b543 100644 --- a/main/gcc/ada/s-shasto.ads +++ b/main/gcc/ada/s-shasto.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 @@ -- provides a more general implementation not dedicated to file -- storage. --- This unit (and shared passive partitions) are supported on all --- GNAT implementations except on OpenVMS (where problems arise from --- trying to share files, and with version numbers of files) - -- -------------------------- -- -- Shared Storage Model -- -- -------------------------- diff --git a/main/gcc/ada/s-soflin.ads b/main/gcc/ada/s-soflin.ads index 7f3ebe45afa..f850cd2ffb0 100644 --- a/main/gcc/ada/s-soflin.ads +++ b/main/gcc/ada/s-soflin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 +140,8 @@ package System.Soft_Links is -- Undefer task abort (non-tasking case, does nothing) procedure Abort_Handler_NT; - -- Handle task abort (non-tasking case, does nothing). Currently, only VMS - -- uses this. + -- Handle task abort (non-tasking case, does nothing). Currently, no port + -- makes use of this, but we retain the interface for possible future use. procedure Update_Exception_NT (X : EO := Current_Target_Exception); -- Handle exception setting. This routine is provided for targets that @@ -300,7 +300,7 @@ package System.Soft_Links is -- Wrapper to the possible user specified traceback decorator to be -- called during automatic output of exception data. - -- The nullity of this wrapper shall correspond to the nullity of the + -- The null value of this wrapper correspond sto the null value of the -- current actual decorator. This is ensured first by the null initial -- value of the corresponding variables, and then by Set_Trace_Decorator -- in g-exctra.adb. diff --git a/main/gcc/ada/s-stalib.ads b/main/gcc/ada/s-stalib.ads index 520fb3c92d1..c7f28fe1355 100644 --- a/main/gcc/ada/s-stalib.ads +++ b/main/gcc/ada/s-stalib.ads @@ -106,7 +106,6 @@ package System.Standard_Library is Lang : Character; -- A character indicating the language raising the exception. -- Set to "A" for exceptions defined by an Ada program. - -- Set to "V" for imported VMS exceptions. -- Set to "C" for imported C++ exceptions. Name_Length : Natural; @@ -122,9 +121,8 @@ package System.Standard_Library is -- identities and names. Foreign_Data : Address; - -- Data for imported exceptions. This represents the exception code - -- for the handling of Import/Export_Exception for the VMS case. - -- This represents the address of the RTTI for the C++ case. + -- Data for imported exceptions. Not used in the Ada case. This + -- represents the address of the RTTI for the C++ case. Raise_Hook : Raise_Action; -- This field can be used to place a "hook" on an exception. If the diff --git a/main/gcc/ada/s-stchop.adb b/main/gcc/ada/s-stchop.adb index bce3e3f391a..05b13dcbe8c 100644 --- a/main/gcc/ada/s-stchop.adb +++ b/main/gcc/ada/s-stchop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, 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- -- @@ -59,7 +59,7 @@ package body System.Stack_Checking.Operations is -- -- This order is important because if at any time a write to the stack -- cache is pending, that write should be followed by a Poll to prevent - -- loosing signals. + -- losing signals. -- -- Note: This function must be compiled with Polling turned off -- diff --git a/main/gcc/ada/s-stoele.adb b/main/gcc/ada/s-stoele.adb index 6a3fe5cfd13..1cb5f92a23c 100644 --- a/main/gcc/ada/s-stoele.adb +++ b/main/gcc/ada/s-stoele.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 @@ package body System.Storage_Elements is -- Conversion to/from address - -- Note qualification below of To_Address to avoid ambiguities on VMS + -- Note qualification below of To_Address to avoid ambiguities systems + -- where Address is a visible integer type. function To_Address is new Ada.Unchecked_Conversion (Storage_Offset, Address); diff --git a/main/gcc/ada/s-taasde.adb b/main/gcc/ada/s-taasde.adb index 315d9ba1355..b111f31a7a0 100644 --- a/main/gcc/ada/s-taasde.adb +++ b/main/gcc/ada/s-taasde.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, 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- -- @@ -60,8 +60,6 @@ package body System.Tasking.Async_Delays is function To_System is new Ada.Unchecked_Conversion (Ada.Task_Identification.Task_Id, Task_Id); - Timer_Server_ID : ST.Task_Id; - Timer_Attention : Boolean := False; pragma Atomic (Timer_Attention); @@ -69,6 +67,8 @@ package body System.Tasking.Async_Delays is pragma Interrupt_Priority (System.Any_Priority'Last); end Timer_Server; + Timer_Server_ID : constant ST.Task_Id := To_System (Timer_Server'Identity); + -- The timer queue is a circular doubly linked list, ordered by absolute -- wakeup time. The first item in the queue is Timer_Queue.Succ. -- It is given a Resume_Time that is larger than any legitimate wakeup @@ -77,6 +77,21 @@ package body System.Tasking.Async_Delays is Timer_Queue : aliased Delay_Block; + package Init_Timer_Queue is end Init_Timer_Queue; + pragma Unreferenced (Init_Timer_Queue); + -- Initialize the Timer_Queue. This is a package to work around the + -- fact that statements are syntactically illegal here. We want this + -- initialization to happen before the Timer_Server is activated. A + -- build-in-place function would also work, but that's not supported + -- on all platforms (e.g. cil). + + package body Init_Timer_Queue is + begin + Timer_Queue.Succ := Timer_Queue'Unchecked_Access; + Timer_Queue.Pred := Timer_Queue'Unchecked_Access; + Timer_Queue.Resume_Time := Duration'Last; + end Init_Timer_Queue; + ------------------------ -- Cancel_Async_Delay -- ------------------------ @@ -138,9 +153,9 @@ package body System.Tasking.Async_Delays is STI.Undefer_Abort_Nestable (D.Self_Id); end Cancel_Async_Delay; - --------------------------- - -- Enqueue_Time_Duration -- - --------------------------- + ---------------------- + -- Enqueue_Duration -- + ---------------------- function Enqueue_Duration (T : Duration; @@ -270,23 +285,11 @@ package body System.Tasking.Async_Delays is ------------------ task body Timer_Server is - function Get_Next_Wakeup_Time return Duration; - -- Used to initialize Next_Wakeup_Time, but also to ensure that - -- Make_Independent is called during the elaboration of this task. - - -------------------------- - -- Get_Next_Wakeup_Time -- - -------------------------- - - function Get_Next_Wakeup_Time return Duration is - begin - STU.Make_Independent; - return Duration'Last; - end Get_Next_Wakeup_Time; + Ignore : constant Boolean := STU.Make_Independent; -- Local Declarations - Next_Wakeup_Time : Duration := Get_Next_Wakeup_Time; + Next_Wakeup_Time : Duration := Duration'Last; Timedout : Boolean; Yielded : Boolean; Now : Duration; @@ -296,7 +299,7 @@ package body System.Tasking.Async_Delays is pragma Unreferenced (Timedout, Yielded); begin - Timer_Server_ID := STPO.Self; + pragma Assert (Timer_Server_ID = STPO.Self); -- Since this package may be elaborated before System.Interrupt, -- we need to call Setup_Interrupt_Mask explicitly to ensure that @@ -400,13 +403,4 @@ package body System.Tasking.Async_Delays is end loop; end Timer_Server; - ------------------------------ - -- Package Body Elaboration -- - ------------------------------ - -begin - Timer_Queue.Succ := Timer_Queue'Access; - Timer_Queue.Pred := Timer_Queue'Access; - Timer_Queue.Resume_Time := Duration'Last; - Timer_Server_ID := To_System (Timer_Server'Identity); end System.Tasking.Async_Delays; diff --git a/main/gcc/ada/s-taasde.ads b/main/gcc/ada/s-taasde.ads index dc4165a122c..46dc17877f3 100644 --- a/main/gcc/ada/s-taasde.ads +++ b/main/gcc/ada/s-taasde.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, 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- -- @@ -113,7 +113,7 @@ package System.Tasking.Async_Delays is private - type Delay_Block is record + type Delay_Block is limited record Self_Id : Task_Id; -- ID of the calling task diff --git a/main/gcc/ada/s-taprop-linux.adb b/main/gcc/ada/s-taprop-linux.adb index 4a81c0880fa..ba5c2122ed9 100644 --- a/main/gcc/ada/s-taprop-linux.adb +++ b/main/gcc/ada/s-taprop-linux.adb @@ -39,6 +39,7 @@ pragma Polling (Off); -- operations. It causes infinite loops and other problems. with Interfaces.C; +with Interfaces.C.Extensions; with System.Task_Info; with System.Tasking.Debug; @@ -61,6 +62,7 @@ package body System.Task_Primitives.Operations is use System.Tasking.Debug; use System.Tasking; use Interfaces.C; + use Interfaces.C.Extensions; use System.OS_Interface; use System.Parameters; use System.OS_Primitives; @@ -629,12 +631,12 @@ package body System.Task_Primitives.Operations is procedure timeval_to_duration (T : not null access timeval; - sec : not null access C.long; + sec : not null access C.Extensions.long_long; usec : not null access C.long); pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); Micro : constant := 10**6; - sec : aliased C.long; + sec : aliased C.Extensions.long_long; usec : aliased C.long; TV : aliased timeval; Result : int; diff --git a/main/gcc/ada/s-taprop-mingw.adb b/main/gcc/ada/s-taprop-mingw.adb index 75d81cb6327..126ef64c1f8 100644 --- a/main/gcc/ada/s-taprop-mingw.adb +++ b/main/gcc/ada/s-taprop-mingw.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -1029,7 +1029,6 @@ package body System.Task_Primitives.Operations is procedure Initialize (Environment_Task : Task_Id) is Discard : BOOL; - pragma Unreferenced (Discard); begin Environment_Task_Id := Environment_Task; diff --git a/main/gcc/ada/s-taprop-vms.adb b/main/gcc/ada/s-taprop-vms.adb deleted file mode 100644 index 53034cad012..00000000000 --- a/main/gcc/ada/s-taprop-vms.adb +++ /dev/null @@ -1,1278 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - --- This package contains all the GNULL primitives that interface directly with --- the underlying OS. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.Tasking.Debug; -with System.OS_Primitives; -with System.Soft_Links; -with System.Aux_DEC; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - use type System.OS_Primitives.OS_Time; - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_Id associated with a thread - - Environment_Task_Id : Task_Id; - -- A variable to hold Task_Id for the environment task - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads) - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_Id); - pragma Inline (Initialize); - -- Initialize various data needed by this package - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_Id); - pragma Inline (Set); - -- Set the self id for the current task - - function Self return Task_Id; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific - - ---------------------------------- - -- ATCB allocation/deallocation -- - ---------------------------------- - - package body ATCB_Allocation is separate; - -- The body of this package is shared across several targets - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Task_Id is - new Ada.Unchecked_Conversion - (System.Task_Primitives.Task_Address, Task_Id); - - function To_Address is - new Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - procedure Timer_Sleep_AST (ID : Address); - pragma Convention (C, Timer_Sleep_AST); - -- Signal the condition variable when AST fires - - procedure Timer_Sleep_AST (ID : Address) is - Result : Interfaces.C.int; - pragma Warnings (Off, Result); - Self_ID : constant Task_Id := To_Task_Id (ID); - begin - Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Timer_Sleep_AST; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the bottom of a thread - -- stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_Id renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are initialized - -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such - -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any - -- status change of RTS. Therefore raising Storage_Error in the following - -- routines should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - L.Prio_Save := 0; - L.Prio := Interfaces.C.int (Prio); - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock - (L : not null access RTS_Lock; - Level : Lock_Level) - is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - --- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? --- Result := pthread_mutexattr_settype_np --- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); --- pragma Assert (Result = 0); - --- Result := pthread_mutexattr_setprotocol --- (Attributes'Access, PTHREAD_PRIO_PROTECT); --- pragma Assert (Result = 0); - --- Result := pthread_mutexattr_setprioceiling --- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); --- pragma Assert (Result = 0); - - Result := pthread_mutex_init (L, Attributes'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : not null access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - Self_ID : constant Task_Id := Self; - All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link; - Current_Prio : System.Any_Priority; - Result : Interfaces.C.int; - - begin - Current_Prio := Get_Priority (Self_ID); - - -- If there is no other tasks, no need to check priorities - - if All_Tasks_Link /= Null_Task - and then L.Prio < Interfaces.C.int (Current_Prio) - then - Ceiling_Violation := True; - return; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - - Ceiling_Violation := False; --- Why is this commented out ??? --- L.Prio_Save := Interfaces.C.int (Current_Prio); --- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); - end Write_Lock; - - procedure Write_Lock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_Id) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_Id) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------------- - -- Set_Ceiling -- - ----------------- - - -- Dynamic priority ceilings are not supported by the underlying system - - procedure Set_Ceiling - (L : not null access Lock; - Prio : System.Any_Priority) - is - pragma Unreferenced (L, Prio); - begin - null; - end Set_Ceiling; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_Id; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - - begin - Result := - pthread_cond_wait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access)); - - -- EINTR is not considered a failure - - pragma Assert (Result = 0 or else Result = EINTR); - - if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - then - Unlock (Self_ID); - raise Standard'Abort_Signal; - end if; - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Sleep_Time : OS_Time; - Result : Interfaces.C.int; - Status : Cond_Value_Type; - - -- The body below requires more comments ??? - - begin - Timedout := False; - Yielded := False; - - Sleep_Time := To_OS_Time (Time, Mode); - - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then - return; - end if; - - Self_ID.Common.LL.AST_Pending := True; - - Sys_Setimr - (Status, 0, Sleep_Time, - Timer_Sleep_AST'Access, To_Address (Self_ID), 0); - - if (Status and 1) /= 1 then - raise Storage_Error; - end if; - - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - pragma Assert (Result = 0); - - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Yielded := True; - - if not Self_ID.Common.LL.AST_Pending then - Timedout := True; - else - Sys_Cantim (Status, To_Address (Self_ID), 0); - pragma Assert ((Status and 1) = 1); - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) - is - Sleep_Time : OS_Time; - Result : Interfaces.C.int; - Status : Cond_Value_Type; - Yielded : Boolean := False; - - begin - if Single_Lock then - Lock_RTS; - end if; - - -- More comments required in body below ??? - - Write_Lock (Self_ID); - - if Time /= 0.0 or else Mode /= Relative then - Sleep_Time := To_OS_Time (Time, Mode); - - if Mode = Relative or else OS_Clock <= Sleep_Time then - Self_ID.Common.State := Delay_Sleep; - Self_ID.Common.LL.AST_Pending := True; - - Sys_Setimr - (Status, 0, Sleep_Time, - Timer_Sleep_AST'Access, To_Address (Self_ID), 0); - - -- Comment following test - - if (Status and 1) /= 1 then - raise Storage_Error; - end if; - - loop - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then - Sys_Cantim (Status, To_Address (Self_ID), 0); - pragma Assert ((Status and 1) = 1); - exit; - end if; - - Result := - pthread_cond_wait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access)); - pragma Assert (Result = 0); - - Yielded := True; - - exit when not Self_ID.Common.LL.AST_Pending; - end loop; - - Self_ID.Common.State := Runnable; - end if; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - if not Yielded then - Result := sched_yield; - pragma Assert (Result = 0); - end if; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration - renames System.OS_Primitives.Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - -- Document origin of this magic constant ??? - return 10#1.0#E-3; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_Id; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - - Priority_Specific_Policy : constant Character := Get_Policy (Prio); - -- Upper case first character of the policy name corresponding to the - -- task as set by a Priority_Specific_Dispatching pragma. - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Dispatching_Policy = 'R' - or else Priority_Specific_Policy = 'R' - or else Time_Slice_Val > 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif Dispatching_Policy = 'F' - or else Priority_Specific_Policy = 'F' - or else Time_Slice_Val = 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - -- SCHED_OTHER priorities are restricted to the range 8 - 15. - -- Since the translation from Underlying priorities results - -- in a range of 16 - 31, dividing by 2 gives the correct result. - - Param.sched_priority := Param.sched_priority / 2; - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_Id) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_Id) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - end Enter_Task; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_Id is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - -- More comments required in body below ??? - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_mutex_init - (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_cond_init - (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_Id; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); - - Task_Name : String (1 .. System.Parameters.Max_Task_Image_Length + 1); - - begin - -- Since the initial signal mask of a thread is inherited from the - -- creator, we need to set our local signal mask to mask all signals - -- during the creation operation, to make sure the new thread is - -- not disturbed by signals before it has set its own Task_Id. - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Interfaces.C.size_t (Stack_Size)); - pragma Assert (Result = 0); - - -- This call may be unnecessary, not sure. ??? - - Result := - pthread_attr_setinheritsched - (Attributes'Access, PTHREAD_EXPLICIT_SCHED); - pragma Assert (Result = 0); - - if T.Common.Task_Image_Len > 0 then - - -- Set thread name to ease debugging - - Task_Name (1 .. T.Common.Task_Image_Len) := - T.Common.Task_Image (1 .. T.Common.Task_Image_Len); - Task_Name (T.Common.Task_Image_Len + 1) := ASCII.NUL; - - Result := pthread_attr_setname_np - (Attributes'Access, Task_Name'Address, Null_Address); - pragma Assert (Result = 0); - end if; - - -- Note: the use of Unrestricted_Access in the following call is needed - -- because otherwise we have an error of getting a access-to-volatile - -- value which points to a non-volatile object. But in this case it is - -- safe to do this, since we know we have no problems with aliasing and - -- Unrestricted_Access bypasses this check. - - Result := - pthread_create - (T.Common.LL.Thread'Unrestricted_Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - - -- ENOMEM is a valid run-time error -- do not shut down - - pragma Assert (Result = 0 - or else Result = EAGAIN or else Result = ENOMEM); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - if Succeeded then - Set_Priority (T, Priority); - end if; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - ATCB_Allocation.Free_ATCB (T); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - null; - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_Id) is - begin - -- Interrupt Server_Tasks may be waiting on an event flag - - if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then - Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); - end if; - end Abort_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - begin - -- Initialize internal state (always to False (D.10 (6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as specified in (RM D.10(9)), otherwise leave state set to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_Id is - begin - return Environment_Task_Id; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Resume_Task; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - begin - null; - end Stop_All_Tasks; - - --------------- - -- Stop_Task -- - --------------- - - function Stop_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Stop_Task; - - ------------------- - -- Continue_Task -- - ------------------- - - function Continue_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Continue_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_Id) is - - -- The DEC Ada facility code defined in Starlet - Ada_Facility : constant := 49; - - function DBGEXT (Control_Block : System.Address) - return System.Aux_DEC.Unsigned_Word; - -- DBGEXT is imported from s-tasdeb.adb and its parameter re-typed - -- as Address to avoid having a VMS specific s-tasdeb.ads. - pragma Import (C, DBGEXT); - pragma Import_Function (DBGEXT, "GNAT$DBGEXT"); - - type Facility_Type is range 0 .. 65535; - - procedure Debug_Register - (ADBGEXT : System.Address; - ATCB_Key : pthread_key_t; - Facility : Facility_Type; - Std_Prolog : Integer); - pragma Import (C, Debug_Register, "CMA$DEBUG_REGISTER"); - begin - Environment_Task_Id := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - -- Pass the context key on to CMA along with the other parameters - Debug_Register - ( - DBGEXT'Address, -- Our DEBUG handling entry point - ATCB_Key, -- CMA context key for our Ada TCB's - Ada_Facility, -- Out facility code - 0 -- False, we don't have the std TCB prolog - ); - - -- Make environment task known here because it doesn't go through - -- Activate_Tasks, which does it for all other tasks. - - Known_Tasks (Known_Tasks'First) := Environment_Task; - Environment_Task.Known_Tasks_Index := Known_Tasks'First; - - Enter_Task (Environment_Task); - end Initialize; - - ----------------------- - -- Set_Task_Affinity -- - ----------------------- - - procedure Set_Task_Affinity (T : ST.Task_Id) is - pragma Unreferenced (T); - - begin - -- Setting task affinity is not supported by the underlying system - - null; - end Set_Task_Affinity; -end System.Task_Primitives.Operations; diff --git a/main/gcc/ada/s-taprop-vxworks.adb b/main/gcc/ada/s-taprop-vxworks.adb index eec3a9da10d..52d12d5103f 100644 --- a/main/gcc/ada/s-taprop-vxworks.adb +++ b/main/gcc/ada/s-taprop-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -1298,7 +1298,6 @@ package body System.Task_Primitives.Operations is C : Task_Id; Dummy : int; - pragma Unreferenced (Dummy); begin Dummy := Int_Lock; diff --git a/main/gcc/ada/s-tarest.adb b/main/gcc/ada/s-tarest.adb index 1436f2a01aa..5d44196216c 100644 --- a/main/gcc/ada/s-tarest.adb +++ b/main/gcc/ada/s-tarest.adb @@ -126,7 +126,7 @@ package body System.Tasking.Restricted.Stages is Elaborated : Access_Boolean; Task_Image : String; Created_Task : Task_Id); - -- Code shared between Create_Restricted_Task_Concurrent and + -- 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. @@ -210,6 +210,9 @@ package body System.Tasking.Restricted.Stages is Secondary_Stack : aliased SSE.Storage_Array (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size * SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100); + 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. pragma Warnings (Off); Secondary_Stack_Address : System.Address := Secondary_Stack'Address; @@ -538,7 +541,6 @@ package body System.Tasking.Restricted.Stages is if CPU /= Unspecified_CPU and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) - or else CPU > Integer (System.Multiprocessors.CPU_Range'Last) or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) then raise Tasking_Error with "CPU not in range"; diff --git a/main/gcc/ada/s-tarest.ads b/main/gcc/ada/s-tarest.ads index 6313be626ab..90c1f2cc134 100644 --- a/main/gcc/ada/s-tarest.ads +++ b/main/gcc/ada/s-tarest.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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,10 +196,9 @@ package System.Tasking.Restricted.Stages is -- This must be called to create a new task, when the sequential partition -- elaboration policy is used. -- - -- The parameters are the same as Create_Restricted_Task_Concurrent, - -- except there is no Chain parameter (for the activation chain), as there - -- is only one global activation chain, which is declared in the body of - -- this package. + -- The parameters are the same as Create_Restricted_Task except there is + -- no Chain parameter (for the activation chain), as there is only one + -- global activation chain, which is declared in the body of this package. procedure Activate_Restricted_Tasks (Chain_Access : Activation_Chain_Access); diff --git a/main/gcc/ada/s-tasdeb-vms.adb b/main/gcc/ada/s-tasdeb-vms.adb deleted file mode 100644 index 6c9ae75e332..00000000000 --- a/main/gcc/ada/s-tasdeb-vms.adb +++ /dev/null @@ -1,2158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . D E B U G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- OpenVMS Version - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with System.Aux_DEC; -with System.CRTL; -with System.Task_Primitives.Operations; -package body System.Tasking.Debug is - - package OSI renames System.OS_Interface; - package STPO renames System.Task_Primitives.Operations; - - use System.Aux_DEC; - - -- Condition value type - - subtype Cond_Value_Type is Unsigned_Longword; - - type Trace_Flag_Set is array (Character) of Boolean; - - Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); - - -- Print_Routine fuction codes - - type Print_Functions is - (No_Print, Print_Newline, Print_Control, - Print_String, Print_Symbol, Print_FAO); - for Print_Functions use - (No_Print => 0, Print_Newline => 1, Print_Control => 2, - Print_String => 3, Print_Symbol => 4, Print_FAO => 5); - - -- Counted ascii type declarations - - subtype Count_Type is Natural range 0 .. 255; - for Count_Type'Object_Size use 8; - - type ASCIC (Count : Count_Type) is record - Text : String (1 .. Count); - end record; - - for ASCIC use record - Count at 0 range 0 .. 7; - end record; - pragma Pack (ASCIC); - - type AASCIC is access ASCIC; - for AASCIC'Size use 32; - - type AASCIC_Array is array (Positive range <>) of AASCIC; - - type ASCIC127 is record - Count : Count_Type; - Text : String (1 .. 127); - end record; - - for ASCIC127 use record - Count at 0 range 0 .. 7; - Text at 1 range 0 .. 127 * 8 - 1; - end record; - - -- DEBUG Event record types used to signal DEBUG about Ada events - - type Debug_Event_Record is record - Code : Unsigned_Word; -- Event code that uniquely identifies event - Flags : Bit_Array_8; -- Flag bits - -- Bit 0: This event allows a parameter list - -- Bit 1: Parameters are address expressions - Sentinal : Unsigned_Byte; -- Sentinal valuye: Always K_EVENT_SENT - TS_Kind : Unsigned_Byte; -- DST type specification: Always K_TS_TASK - DType : Unsigned_Byte; -- DTYPE of parameter if of atomic data type - -- Always K_DTYPE_TASK - MBZ : Unsigned_Byte; -- Unused (must be zero) - Minchr : Count_Type; -- Minimum chars needed to identify event - Name : ASCIC (31); -- Event name uppercase only - Help : AASCIC; -- Event description - end record; - - for Debug_Event_Record use record - Code at 0 range 0 .. 15; - Flags at 2 range 0 .. 7; - Sentinal at 3 range 0 .. 7; - TS_Kind at 4 range 0 .. 7; - Dtype at 5 range 0 .. 7; - MBZ at 6 range 0 .. 7; - Minchr at 7 range 0 .. 7; - Name at 8 range 0 .. 32 * 8 - 1; - Help at 40 range 0 .. 31; - end record; - - type Ada_Event_Control_Block_Type is record - Code : Unsigned_Word; -- Reserved and defined by DEBUG - Unused1 : Unsigned_Byte; -- Reserved and defined by DEBUG - Sentinal : Unsigned_Byte; -- Reserved and defined by DEBUG - Facility : Unsigned_Word; -- Reserved and defined by DEBUG - Flags : Unsigned_Word; -- Reserved and defined by DEBUG - Value : Unsigned_Longword; -- Reserved and defined by DEBUG - Unused2 : Unsigned_Longword; -- Reserved and defined by DEBUG - Sigargs : Unsigned_Longword; - P1 : Unsigned_Longword; - Sub_Event : Unsigned_Longword; - end record; - - for Ada_Event_Control_Block_Type use record - Code at 0 range 0 .. 15; - Unused1 at 2 range 0 .. 7; - Sentinal at 3 range 0 .. 7; - Facility at 4 range 0 .. 15; - Flags at 6 range 0 .. 15; - Value at 8 range 0 .. 31; - Unused2 at 12 range 0 .. 31; - Sigargs at 16 range 0 .. 31; - P1 at 20 range 0 .. 31; - Sub_Event at 24 range 0 .. 31; - end record; - - type Ada_Event_Control_Block_Access is access Ada_Event_Control_Block_Type; - for Ada_Event_Control_Block_Access'Size use 32; - - -- Print_Routine_Type with max optional parameters - - type Print_Routine_Type is access procedure - (Print_Function : Print_Functions; - Print_Subfunction : Print_Functions; - P1 : Unsigned_Longword := 0; - P2 : Unsigned_Longword := 0; - P3 : Unsigned_Longword := 0; - P4 : Unsigned_Longword := 0; - P5 : Unsigned_Longword := 0; - P6 : Unsigned_Longword := 0); - for Print_Routine_Type'Size use 32; - - --------------- - -- Constants -- - --------------- - - -- These are used to obtain and convert task values - K_CVT_VALUE_NUM : constant := 1; - K_CVT_NUM_VALUE : constant := 2; - K_NEXT_TASK : constant := 3; - - -- These are used to ask ADA to display task information - K_SHOW_TASK : constant := 4; - K_SHOW_STAT : constant := 5; - K_SHOW_DEADLOCK : constant := 6; - - -- These are used to get and set various attributes of one or more tasks - -- Task state - -- K_GET_STATE : constant := 7; - -- K_GET_ACTIVE : constant := 8; - -- K_SET_ACTIVE : constant := 9; - K_SET_ABORT : constant := 10; - -- K_SET_HOLD : constant := 11; - - -- Task priority - K_GET_PRIORITY : constant := 12; - K_SET_PRIORITY : constant := 13; - K_RESTORE_PRIORITY : constant := 14; - - -- Task registers - -- K_GET_REGISTERS : constant := 15; - -- K_SET_REGISTERS : constant := 16; - - -- These are used to control definable events - K_ENABLE_EVENT : constant := 17; - K_DISABLE_EVENT : constant := 18; - K_ANNOUNCE_EVENT : constant := 19; - - -- These are used to control time-slicing. - -- K_SHOW_TIME_SLICE : constant := 20; - -- K_SET_TIME_SLICE : constant := 21; - - -- This is used to symbolize task stack addresses. - -- K_SYMBOLIZE_ADDRESS : constant := 22; - - K_GET_CALLER : constant := 23; - -- This is used to obtain the task value of the caller task - - -- Miscellaneous functions - see below for details - - K_CLEANUP_EVENT : constant := 24; - K_SHOW_EVENT_DEF : constant := 25; - -- K_CHECK_TASK_STACK : constant := 26; -- why commented out ??? - - -- This is used to obtain the DBGEXT-interface revision level - -- K_GET_DBGEXT_REV : constant := 27; -- why commented out ??? - - K_GET_STATE_1 : constant := 28; - -- This is used to obtain additional state info, primarily for PCA - - K_FIND_EVENT_BY_CODE : constant := 29; - K_FIND_EVENT_BY_NAME : constant := 30; - -- These are used to search for user-defined event entries - - -- This is used to stop task schedulding. Why commented out ??? - -- K_STOP_ALL_OTHER_TASKS : constant := 31; - - -- Debug event constants - - K_TASK_NOT_EXIST : constant := 3; - K_SUCCESS : constant := 1; - K_EVENT_SENT : constant := 16#9A#; - K_TS_TASK : constant := 18; - K_DTYPE_TASK : constant := 44; - - -- Status signal constants - - SS_BADPARAM : constant := 20; - SS_NORMAL : constant := 1; - - -- Miscellaneous mask constants - - V_EVNT_ALL : constant := 0; - V_Full_Display : constant := 11; - V_Suppress_Header : constant := 13; - - -- CMA constants (why are some commented out???) - - CMA_C_DEBGET_GUARDSIZE : constant := 1; - CMA_C_DEBGET_IS_HELD : constant := 2; --- CMA_C_DEBGET_IS_INITIAL : constant := 3; --- CMA_C_DEBGET_NUMBER : constant := 4; - CMA_C_DEBGET_STACKPTR : constant := 5; - CMA_C_DEBGET_STACK_BASE : constant := 6; - CMA_C_DEBGET_STACK_TOP : constant := 7; - CMA_C_DEBGET_SCHED_STATE : constant := 8; - CMA_C_DEBGET_YELLOWSIZE : constant := 9; --- CMA_C_DEBGET_BASE_PRIO : constant := 10; --- CMA_C_DEBGET_REGS : constant := 11; --- CMA_C_DEBGET_ALT_PENDING : constant := 12; --- CMA_C_DEBGET_ALT_A_ENABLE : constant := 13; --- CMA_C_DEBGET_ALT_G_ENABLE : constant := 14; --- CMA_C_DEBGET_SUBSTATE : constant := 15; --- CMA_C_DEBGET_OBJECT_ADDR : constant := 16; --- CMA_C_DEBGET_THKIND : constant := 17; --- CMA_C_DEBGET_DETACHED : constant := 18; - CMA_C_DEBGET_TCB_SIZE : constant := 19; --- CMA_C_DEBGET_START_PC : constant := 20; --- CMA_C_DEBGET_NEXT_PC : constant := 22; --- CMA_C_DEBGET_POLICY : constant := 23; --- CMA_C_DEBGET_STACK_YELLOW : constant := 24; --- CMA_C_DEBGET_STACK_DEFAULT : constant := 25; - - -- Miscellaneous counted ascii constants - - Star : constant AASCIC := new ASCIC'(2, ("* ")); - NoStar : constant AASCIC := new ASCIC'(2, (" ")); - Hold : constant AASCIC := new ASCIC'(4, ("HOLD")); - NoHold : constant AASCIC := new ASCIC'(4, (" ")); - Header : constant AASCIC := new ASCIC ' - (60, (" task id pri hold state substate task object")); - Empty_Text : constant AASCIC := new ASCIC (0); - - -- DEBUG Ada tasking states equated to their GNAT tasking equivalents - - Ada_State_Invalid_State : constant AASCIC := - new ASCIC'(17, "Invalid state "); --- Ada_State_Abnormal : constant AASCIC := --- new ASCIC'(17, "Abnormal "); - Ada_State_Aborting : constant AASCIC := - new ASCIC'(17, "Aborting "); -- Aborting (new) --- Ada_State_Completed_Abn : constant AASCIC := --- new ASCIC'(17, "Completed [abn] "); --- Ada_State_Completed_Exc : constant AASCIC := --- new ASCIC'(17, "Completed [exc] "); - Ada_State_Completed : constant AASCIC := - new ASCIC'(17, "Completed "); -- Master_Completion_Sleep - Ada_State_Runnable : constant AASCIC := - new ASCIC'(17, "Runnable "); -- Runnable - Ada_State_Activating : constant AASCIC := - new ASCIC'(17, "Activating "); - Ada_State_Accept : constant AASCIC := - new ASCIC'(17, "Accept "); -- Acceptor_Sleep - Ada_State_Select_or_Delay : constant AASCIC := - new ASCIC'(17, "Select or delay "); -- Acceptor_Delay_Sleep - Ada_State_Select_or_Term : constant AASCIC := - new ASCIC'(17, "Select or term. "); -- Terminate_Alternative - Ada_State_Select_or_Abort : constant AASCIC := - new ASCIC'(17, "Select or abort "); -- Async_Select_Sleep (new) --- Ada_State_Select : constant AASCIC := --- new ASCIC'(17, "Select "); - Ada_State_Activating_Tasks : constant AASCIC := - new ASCIC'(17, "Activating tasks "); -- Activator_Sleep - Ada_State_Delay : constant AASCIC := - new ASCIC'(17, "Delay "); -- AST_Pending --- Ada_State_Dependents : constant AASCIC := --- new ASCIC'(17, "Dependents "); - Ada_State_Entry_Call : constant AASCIC := - new ASCIC'(17, "Entry call "); -- Entry_Caller_Sleep - Ada_State_Cond_Entry_Call : constant AASCIC := - new ASCIC'(17, "Cond. entry call "); -- Call.Mode.Conditional_Call - Ada_State_Timed_Entry_Call : constant AASCIC := - new ASCIC'(17, "Timed entry call "); -- Call.Mode.Timed_Call - Ada_State_Async_Entry_Call : constant AASCIC := - new ASCIC'(17, "Async entry call "); -- Call.Mode.Asynchronous_Call (new) --- Ada_State_Dependents_Exc : constant AASCIC := --- new ASCIC'(17, "Dependents [exc] "); - Ada_State_IO_or_AST : constant AASCIC := - new ASCIC'(17, "I/O or AST "); -- AST_Server_Sleep --- Ada_State_Shared_Resource : constant AASCIC := --- new ASCIC'(17, "Shared resource "); - Ada_State_Not_Yet_Activated : constant AASCIC := - new ASCIC'(17, "Not yet activated"); -- Unactivated --- Ada_State_Terminated_Abn : constant AASCIC := --- new ASCIC'(17, "Terminated [abn] "); --- Ada_State_Terminated_Exc : constant AASCIC := --- new ASCIC'(17, "Terminated [exc] "); - Ada_State_Terminated : constant AASCIC := - new ASCIC'(17, "Terminated "); -- Terminated - Ada_State_Server : constant AASCIC := - new ASCIC'(17, "Server "); -- Servers - Ada_State_Async_Hold : constant AASCIC := - new ASCIC'(17, "Async_Hold "); -- Async_Hold - - -- Task state counted ascii constants - - Debug_State_Emp : constant AASCIC := new ASCIC'(5, " "); - Debug_State_Run : constant AASCIC := new ASCIC'(5, "RUN "); - Debug_State_Rea : constant AASCIC := new ASCIC'(5, "READY"); - Debug_State_Sus : constant AASCIC := new ASCIC'(5, "SUSP "); - Debug_State_Ter : constant AASCIC := new ASCIC'(5, "TERM "); - - -- Priority order of event display - - Global_Event_Display_Order : constant array (Event_Kind_Type) - of Event_Kind_Type := ( - Debug_Event_Abort_Terminated, - Debug_Event_Activating, - Debug_Event_Dependents_Exception, - Debug_Event_Exception_Terminated, - Debug_Event_Handled, - Debug_Event_Handled_Others, - Debug_Event_Preempted, - Debug_Event_Rendezvous_Exception, - Debug_Event_Run, - Debug_Event_Suspended, - Debug_Event_Terminated); - - -- Constant array defining all debug events - - Event_Directory : constant array (Event_Kind_Type) - of Debug_Event_Record := ( - (Debug_Event_Activating, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 2, - (31, "ACTIVATING "), - new ASCIC'(41, "!_a task is about to begin its activation")), - - (Debug_Event_Run, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 2, - (31, "RUN "), - new ASCIC'(24, "!_a task is about to run")), - - (Debug_Event_Suspended, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "SUSPENDED "), - new ASCIC'(33, "!_a task is about to be suspended")), - - (Debug_Event_Preempted, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "PREEMPTED "), - new ASCIC'(33, "!_a task is about to be preempted")), - - (Debug_Event_Terminated, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "TERMINATED "), - new ASCIC'(57, - "!_a task is terminating (including by abort or exception)")), - - (Debug_Event_Abort_Terminated, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 2, - (31, "ABORT_TERMINATED "), - new ASCIC'(40, "!_a task is terminating because of abort")), - - (Debug_Event_Exception_Terminated, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "EXCEPTION_TERMINATED "), - new ASCIC'(47, "!_a task is terminating because of an exception")), - - (Debug_Event_Rendezvous_Exception, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 3, - (31, "RENDEZVOUS_EXCEPTION "), - new ASCIC'(49, "!_an exception is propagating out of a rendezvous")), - - (Debug_Event_Handled, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "HANDLED "), - new ASCIC'(37, "!_an exception is about to be handled")), - - (Debug_Event_Dependents_Exception, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "DEPENDENTS_EXCEPTION "), - new ASCIC'(64, - "!_an exception is about to cause a task to await dependent tasks")), - - (Debug_Event_Handled_Others, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "HANDLED_OTHERS "), - new ASCIC'(58, - "!_an exception is about to be handled in an OTHERS handler"))); - - -- Help on events displayed in DEBUG - - Event_Def_Help : constant AASCIC_Array := ( - new ASCIC'(0, ""), - new ASCIC'(65, - " The general forms of commands to set a breakpoint or tracepoint"), - new ASCIC'(22, " on an Ada event are:"), - new ASCIC'(73, " SET BREAK/EVENT=event [task[, ... ]] " & - "[WHEN(expr)] [DO(comnd[; ... ])]"), - new ASCIC'(73, " SET TRACE/EVENT=event [task[, ... ]] " & - "[WHEN(expr)] [DO(comnd[; ... ])]"), - new ASCIC'(0, ""), - new ASCIC'(65, - " If tasks are specified, the breakpoint will trigger only if the"), - new ASCIC'(40, " event occurs for those specific tasks."), - new ASCIC'(0, ""), - new ASCIC'(39, " Ada event names and their definitions"), - new ASCIC'(0, "")); - - ----------------------- - -- Package Variables -- - ----------------------- - - AC_Buffer : ASCIC127; - - Events_Enabled_Count : Integer := 0; - - Print_Routine_Bufsiz : constant := 132; - Print_Routine_Bufcnt : Integer := 0; - Print_Routine_Linbuf : String (1 .. Print_Routine_Bufsiz); - - Global_Task_Debug_Events : Debug_Event_Array := - (False, False, False, False, False, False, False, False, - False, False, False, False, False, False, False, False); - -- Global table of task debug events set by the debugger - - -------------------------- - -- Exported Subprograms -- - -------------------------- - - procedure Default_Print_Routine - (Print_Function : Print_Functions; - Print_Subfunction : Print_Functions; - P1 : Unsigned_Longword := 0; - P2 : Unsigned_Longword := 0; - P3 : Unsigned_Longword := 0; - P4 : Unsigned_Longword := 0; - P5 : Unsigned_Longword := 0; - P6 : Unsigned_Longword := 0); - -- The default print routine if not overridden. - -- Print_Function determines option argument formatting. - -- Print_Subfunction buffers output if No_Print, calls Put_Output if - -- Print_Newline - - pragma Export_Procedure - (Default_Print_Routine, - Mechanism => (Value, Value, Reference, Reference, Reference)); - - -------------------------- - -- Imported Subprograms -- - -------------------------- - - procedure Debug_Get - (Thread_Id : OSI.Thread_Id; - Item_Req : Unsigned_Word; - Out_Buff : System.Address; - Buff_Siz : Unsigned_Word); - - procedure Debug_Get - (Thread_Id : OSI.Thread_Id; - Item_Req : Unsigned_Word; - Out_Buff : Unsigned_Longword; - Buff_Siz : Unsigned_Word); - pragma Import (External, Debug_Get); - - pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET", - (OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word), - (Reference, Value, Reference, Value)); - - pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET", - (OSI.Thread_Id, Unsigned_Word, Unsigned_Longword, Unsigned_Word), - (Reference, Value, Reference, Value)); - - procedure FAOL - (Status : out Cond_Value_Type; - Ctrstr : String; - Outlen : out Unsigned_Word; - Outbuf : out String; - Prmlst : Unsigned_Longword_Array); - pragma Import (External, FAOL); - - pragma Import_Valued_Procedure (FAOL, "SYS$FAOL", - (Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array), - (Value, Descriptor (S), Reference, Descriptor (S), Reference)); - - procedure Put_Output ( - Status : out Cond_Value_Type; - Message_String : String); - - procedure Put_Output (Message_String : String); - pragma Import (External, Put_Output); - - pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT", - (Cond_Value_Type, String), - (Value, Short_Descriptor (S))); - - pragma Import_Procedure (Put_Output, "LIB$PUT_OUTPUT", - (String), - (Short_Descriptor (S))); - - procedure Signal - (Condition_Value : Cond_Value_Type; - Number_Of_Arguments : Integer := Integer'Null_Parameter; - FAO_Argument_1 : Unsigned_Longword := - Unsigned_Longword'Null_Parameter); - pragma Import (External, Signal); - - pragma Import_Procedure (Signal, "LIB$SIGNAL", - (Cond_Value_Type, Integer, Unsigned_Longword), - (Value, Value, Value), - Number_Of_Arguments); - - ---------------------------- - -- Generic Instantiations -- - ---------------------------- - - function Fetch is new Fetch_From_Address (Unsigned_Longword); - pragma Unreferenced (Fetch); - - procedure Free is new Ada.Unchecked_Deallocation - (Object => Ada_Event_Control_Block_Type, - Name => Ada_Event_Control_Block_Access); - - function To_AASCIC is new - Ada.Unchecked_Conversion (Unsigned_Longword, AASCIC); - - function To_Addr is new - Ada.Unchecked_Conversion (Task_Procedure_Access, Address); - pragma Unreferenced (To_Addr); - - function To_EVCB is new - Ada.Unchecked_Conversion - (Unsigned_Longword, Ada_Event_Control_Block_Access); - - function To_Integer is new - Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); - - function To_Print_Routine_Type is new - Ada.Unchecked_Conversion (Short_Address, Print_Routine_Type); - - -- Optional argumements passed to Print_Routine have to be - -- Unsigned_Longwords so define the required Unchecked_Conversions - - function To_UL is new - Ada.Unchecked_Conversion (AASCIC, Unsigned_Longword); - - function To_UL is new - Ada.Unchecked_Conversion (Integer, Unsigned_Longword); - - function To_UL is new - Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); - - pragma Warnings (Off); -- Different sizes - function To_UL is new - Ada.Unchecked_Conversion (Task_Entry_Index, Unsigned_Longword); - pragma Warnings (On); - - function To_UL is new - Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); - - function To_UL is new - Ada.Unchecked_Conversion - (Ada_Event_Control_Block_Access, Unsigned_Longword); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - subtype Function_Codes is System.Aux_DEC.Unsigned_Word range 1 .. 31; - -- The 31 function codes sent by the debugger needed to implement - -- tasking support, enumerated below. - - type Register_Array is array (Natural range 0 .. 16) of - System.Aux_DEC.Unsigned_Longword; - -- The register array is a holdover from VAX and not used - -- on Alpha or I64 but is kept as a filler below. - - type DBGEXT_Control_Block (Function_Code : Function_Codes) is record - Facility_ID : System.Aux_DEC.Unsigned_Word; - -- For GNAT use the "Ada" facility ID - Status : System.Aux_DEC.Unsigned_Longword; - -- Successful or otherwise returned status - Flags : System.Aux_DEC.Bit_Array_32; - -- Used to flag event as global - Print_Routine : System.Aux_DEC.Short_Address; - -- The print subprogram the caller wants to use for output - Event_Code_or_EVCB : System.Aux_DEC.Unsigned_Longword; - -- Dual use Event Code or EVent Control Block - Event_Value_or_Name : System.Aux_DEC.Unsigned_Longword; - -- Dual use Event Value or Event Name string pointer - Event_Entry : System.Aux_DEC.Unsigned_Longword; - Task_Value : Task_Id; - Task_Number : Integer; - Ada_Flags : System.Aux_DEC.Bit_Array_32; - Priority : System.Aux_DEC.Bit_Array_32; - Active_Registers : System.Aux_DEC.Short_Address; - - case Function_Code is - when K_GET_STATE_1 => - Base_Priority : System.Aux_DEC.Bit_Array_32; - Task_Type_Name : System.Aux_DEC.Short_Address; - Creation_PC : System.Aux_DEC.Short_Address; - Parent_Task_ID : Task_Id; - - when others => - Ignored_Unused : Register_Array; - - end case; - end record; - - for DBGEXT_Control_Block use record - Function_Code at 0 range 0 .. 15; - Facility_ID at 2 range 0 .. 15; - Status at 4 range 0 .. 31; - Flags at 8 range 0 .. 31; - Print_Routine at 12 range 0 .. 31; - Event_Code_or_EVCB at 16 range 0 .. 31; - Event_Value_or_Name at 20 range 0 .. 31; - Event_Entry at 24 range 0 .. 31; - Task_Value at 28 range 0 .. 31; - Task_Number at 32 range 0 .. 31; - Ada_Flags at 36 range 0 .. 31; - Priority at 40 range 0 .. 31; - Active_Registers at 44 range 0 .. 31; - Ignored_Unused at 48 range 0 .. 17 * 32 - 1; - Base_Priority at 48 range 0 .. 31; - Task_Type_Name at 52 range 0 .. 31; - Creation_PC at 56 range 0 .. 31; - Parent_Task_ID at 60 range 0 .. 31; - end record; - - type DBGEXT_Control_Block_Access is access all DBGEXT_Control_Block; - - function DBGEXT (Control_Block : DBGEXT_Control_Block_Access) - return System.Aux_DEC.Unsigned_Word; - -- Exported to s-taprop.adb to avoid having a VMS specific s-tasdeb.ads - pragma Convention (C, DBGEXT); - pragma Export_Function (DBGEXT, "GNAT$DBGEXT"); - -- This routine is called by CMA when VMS DEBUG wants the Gnat RTL - -- to give it some assistance (primarily when tasks are debugged). - -- - -- The single parameter is an "external control block". On input to - -- the Gnat RTL this control block determines the debugging function - -- to be performed, and supplies parameters. This routine cases on - -- the function code, and calls the appropriate Gnat RTL routine, - -- which returns values by modifying the external control block. - - procedure Announce_Event - (Event_EVCB : Unsigned_Longword; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Announce the occurence of a DEBUG tasking event - - procedure Cleanup_Event (Event_EVCB : Unsigned_Longword); - -- After DEBUG has processed an event that has signalled, the signaller - -- must cleanup. Cleanup consists of freeing the event control block. - - procedure Disable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type); - -- Disable a DEBUG tasking event - - function DoAC (S : String) return Address; - -- Convert a string to the address of an internal buffer containing - -- the counted ASCII. - - procedure Enable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type); - -- Enable a requested DEBUG tasking event - - procedure Find_Event_By_Code - (Event_Code : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type); - -- Convert an event code to the address of the event entry - - procedure Find_Event_By_Name - (Event_Name : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type); - -- Find an event entry given the event name - - procedure List_Entry_Waiters - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- List information about tasks waiting on an entry - - procedure Put (S : String); - -- Display S on standard output - - procedure Put_Line (S : String := ""); - -- Display S on standard output with an additional line terminator - - procedure Show_Event - (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Show what events are available - - procedure Show_One_Task - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Display information about one task - - procedure Show_Rendezvous - (Task_Value : Task_Id; - Ada_State : AASCIC := Empty_Text; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Display information about a task rendezvous - - procedure Trace_Output (Message_String : String); - -- Call Put_Output if Trace_on ("VMS") - - procedure Write (Fd : Integer; S : String; Count : Integer); - - -------------------- - -- Announce_Event -- - -------------------- - - procedure Announce_Event - (Event_EVCB : Unsigned_Longword; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - EVCB : constant Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB); - - Event_Kind : constant Event_Kind_Type := - (if EVCB.Sub_Event /= 0 - then Event_Kind_Type (EVCB.Sub_Event) - else Event_Kind_Type (EVCB.Code)); - - TI : constant String := " Task %TASK !UI is "; - -- Announce prefix - - begin - Trace_Output ("Announce called"); - - case Event_Kind is - when Debug_Event_Activating => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "about to begin its activation")), - EVCB.Value); - when Debug_Event_Exception_Terminated => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "terminating because of an exception")), - EVCB.Value); - when Debug_Event_Run => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "about to run")), - EVCB.Value); - when Debug_Event_Abort_Terminated => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "terminating because of abort")), - EVCB.Value); - when Debug_Event_Terminated => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "terminating normally")), - EVCB.Value); - when others => null; - end case; - end Announce_Event; - - ------------------- - -- Cleanup_Event -- - ------------------- - - procedure Cleanup_Event (Event_EVCB : Unsigned_Longword) is - EVCB : Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB); - begin - Free (EVCB); - end Cleanup_Event; - - ------------------------ - -- Continue_All_Tasks -- - ------------------------ - - procedure Continue_All_Tasks is - begin - null; -- VxWorks - end Continue_All_Tasks; - - ------------ - -- DBGEXT -- - ------------ - - function DBGEXT - (Control_Block : DBGEXT_Control_Block_Access) - return System.Aux_DEC.Unsigned_Word - is - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access; - begin - Trace_Output ("DBGEXT called"); - - if Control_Block.Print_Routine /= Address_Zero then - Print_Routine := To_Print_Routine_Type (Control_Block.Print_Routine); - end if; - - case Control_Block.Function_Code is - - -- Convert a task value to a task number. - -- The output results are stored in the CONTROL_BLOCK. - - when K_CVT_VALUE_NUM => - Trace_Output ("DBGEXT param 1 - CVT Value to NUM"); - Control_Block.Task_Number := - Control_Block.Task_Value.Known_Tasks_Index + 1; - Control_Block.Status := K_SUCCESS; - Trace_Output ("Task Number: "); - Trace_Output (Integer'Image (Control_Block.Task_Number)); - return SS_NORMAL; - - -- Convert a task number to a task value. - -- The output results are stored in the CONTROL_BLOCK. - - when K_CVT_NUM_VALUE => - Trace_Output ("DBGEXT param 2 - CVT NUM to Value"); - Trace_Output ("Task Number: "); - Trace_Output (Integer'Image (Control_Block.Task_Number)); - Control_Block.Task_Value := - Known_Tasks (Control_Block.Task_Number - 1); - Control_Block.Status := K_SUCCESS; - Trace_Output ("Task Value: "); - Trace_Output (Unsigned_Longword'Image - (To_UL (Control_Block.Task_Value))); - return SS_NORMAL; - - -- Obtain the "next" task after a specified task. - -- ??? To do: If specified check the PRIORITY, STATE, and HOLD - -- fields to restrict the selection of the next task. - -- The output results are stored in the CONTROL_BLOCK. - - when K_NEXT_TASK => - Trace_Output ("DBGEXT param 3 - Next Task"); - Trace_Output ("Task Value: "); - Trace_Output (Unsigned_Longword'Image - (To_UL (Control_Block.Task_Value))); - - if Control_Block.Task_Value = null then - Control_Block.Task_Value := Known_Tasks (Known_Tasks'First); - else - Control_Block.Task_Value := - Known_Tasks (Control_Block.Task_Value.Known_Tasks_Index + 1); - end if; - - if Control_Block.Task_Value = null then - Control_Block.Task_Value := Known_Tasks (Known_Tasks'First); - end if; - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- Display the state of a task. The FULL bit is checked to decide if - -- a full or brief task display is desired. The output results are - -- stored in the CONTROL_BLOCK. - - when K_SHOW_TASK => - Trace_Output ("DBGEXT param 4 - Show Task"); - - if Control_Block.Task_Value = null then - Control_Block.Status := K_TASK_NOT_EXIST; - else - Show_One_Task - (Control_Block.Task_Value, - Control_Block.Ada_Flags (V_Full_Display), - Control_Block.Ada_Flags (V_Suppress_Header), - Print_Routine); - - Control_Block.Status := K_SUCCESS; - end if; - - return SS_NORMAL; - - -- Enable a requested DEBUG tasking event - - when K_ENABLE_EVENT => - Trace_Output ("DBGEXT param 17 - Enable Event"); - Enable_Event - (Control_Block.Flags, - Control_Block.Event_Value_or_Name, - Control_Block.Event_Code_or_EVCB, - Control_Block.Status); - - return SS_NORMAL; - - -- Disable a DEBUG tasking event - - when K_DISABLE_EVENT => - Trace_Output ("DBGEXT param 18 - Disable Event"); - Disable_Event - (Control_Block.Flags, - Control_Block.Event_Value_or_Name, - Control_Block.Event_Code_or_EVCB, - Control_Block.Status); - - return SS_NORMAL; - - -- Announce the occurence of a DEBUG tasking event - - when K_ANNOUNCE_EVENT => - Trace_Output ("DBGEXT param 19 - Announce Event"); - Announce_Event - (Control_Block.Event_Code_or_EVCB, - Print_Routine); - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- After DEBUG has processed an event that has signalled, - -- the signaller must cleanup. - -- Cleanup consists of freeing the event control block. - - when K_CLEANUP_EVENT => - Trace_Output ("DBGEXT param 24 - Cleanup Event"); - Cleanup_Event (Control_Block.Event_Code_or_EVCB); - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- Show what events are available - - when K_SHOW_EVENT_DEF => - Trace_Output ("DBGEXT param 25 - Show Event Def"); - Show_Event (Print_Routine); - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- Convert an event code to the address of the event entry - - when K_FIND_EVENT_BY_CODE => - Trace_Output ("DBGEXT param 29 - Find Event by Code"); - Find_Event_By_Code - (Control_Block.Event_Code_or_EVCB, - Control_Block.Event_Entry, - Control_Block.Status); - - return SS_NORMAL; - - -- Find an event entry given the event name - - when K_FIND_EVENT_BY_NAME => - Trace_Output ("DBGEXT param 30 - Find Event by Name"); - Find_Event_By_Name - (Control_Block.Event_Value_or_Name, - Control_Block.Event_Entry, - Control_Block.Status); - return SS_NORMAL; - - -- ??? To do: Implement priority events - -- Get, set or restore a task's priority - - when K_GET_PRIORITY or K_SET_PRIORITY or K_RESTORE_PRIORITY => - Trace_Output ("DBGEXT priority param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement show statistics event - -- Display task statistics - - when K_SHOW_STAT => - Trace_Output ("DBGEXT show stat param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement get caller event - -- Obtain the caller of a task in a rendezvous. If no rendezvous, - -- null is returned - - when K_GET_CALLER => - Trace_Output ("DBGEXT get caller param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement set terminate event - -- Terminate a task - - when K_SET_ABORT => - Trace_Output ("DBGEXT set terminate param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement show deadlock event - -- Detect a deadlock - - when K_SHOW_DEADLOCK => - Trace_Output ("DBGEXT show deadlock param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - when others => - Trace_Output ("DBGEXT bad param: "); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - end case; - end DBGEXT; - - --------------------------- - -- Default_Print_Routine -- - --------------------------- - - procedure Default_Print_Routine - (Print_Function : Print_Functions; - Print_Subfunction : Print_Functions; - P1 : Unsigned_Longword := 0; - P2 : Unsigned_Longword := 0; - P3 : Unsigned_Longword := 0; - P4 : Unsigned_Longword := 0; - P5 : Unsigned_Longword := 0; - P6 : Unsigned_Longword := 0) - is - Status : Cond_Value_Type; - Linlen : Unsigned_Word; - Item_List : Unsigned_Longword_Array (1 .. 17) := - (1 .. 17 => 0); - begin - - case Print_Function is - when Print_Control | Print_String => - null; - - -- Formatted Ascii Output - - when Print_FAO => - Item_List (1) := P2; - Item_List (2) := P3; - Item_List (3) := P4; - Item_List (4) := P5; - Item_List (5) := P6; - FAOL - (Status, - To_AASCIC (P1).Text, - Linlen, - Print_Routine_Linbuf - (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz), - Item_List); - - Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen); - - -- Symbolic output - - when Print_Symbol => - Item_List (1) := P1; - FAOL - (Status, - "!XI", - Linlen, - Print_Routine_Linbuf - (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz), - Item_List); - - Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen); - - when others => - null; - end case; - - case Print_Subfunction is - - -- Output buffer with a terminating newline - - when Print_Newline => - Put_Output (Status, - Print_Routine_Linbuf (1 .. Print_Routine_Bufcnt)); - Print_Routine_Bufcnt := 0; - - -- Buffer the output - - when No_Print => - null; - - when others => - null; - end case; - - end Default_Print_Routine; - - ------------------- - -- Disable_Event -- - ------------------- - - procedure Disable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type) - is - Task_Value : Task_Id; - Task_Index : constant Integer := Integer (Event_Value) - 1; - begin - - Events_Enabled_Count := Events_Enabled_Count - 1; - - if Flags (V_EVNT_ALL) then - Global_Task_Debug_Events (Integer (Event_Code)) := False; - Status := K_SUCCESS; - else - if Task_Index in Known_Tasks'Range then - Task_Value := Known_Tasks (Task_Index); - if Task_Value /= null then - Task_Value.Common.Debug_Events (Integer (Event_Code)) := False; - Status := K_SUCCESS; - else - Status := K_TASK_NOT_EXIST; - end if; - else - Status := K_TASK_NOT_EXIST; - end if; - end if; - - -- Keep count of events for efficiency - - if Events_Enabled_Count <= 0 then - Events_Enabled_Count := 0; - Global_Task_Debug_Event_Set := False; - end if; - - end Disable_Event; - - ---------- - -- DoAC -- - ---------- - - function DoAC (S : String) return Address is - begin - AC_Buffer.Count := S'Length; - AC_Buffer.Text (1 .. AC_Buffer.Count) := S; - return AC_Buffer'Address; - end DoAC; - - ------------------ - -- Enable_Event -- - ------------------ - - procedure Enable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type) - is - Task_Value : Task_Id; - Task_Index : constant Integer := Integer (Event_Value) - 1; - - begin - -- At least one event enabled, any and all events will cause a - -- condition to be raised and checked. Major tasking slowdown. - - Global_Task_Debug_Event_Set := True; - Events_Enabled_Count := Events_Enabled_Count + 1; - - if Flags (V_EVNT_ALL) then - Global_Task_Debug_Events (Integer (Event_Code)) := True; - Status := K_SUCCESS; - else - if Task_Index in Known_Tasks'Range then - Task_Value := Known_Tasks (Task_Index); - if Task_Value /= null then - Task_Value.Common.Debug_Events (Integer (Event_Code)) := True; - Status := K_SUCCESS; - else - Status := K_TASK_NOT_EXIST; - end if; - else - Status := K_TASK_NOT_EXIST; - end if; - end if; - - end Enable_Event; - - ------------------------ - -- Find_Event_By_Code -- - ------------------------ - - procedure Find_Event_By_Code - (Event_Code : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type) - is - K_SUCCESS : constant := 1; - K_NO_SUCH_EVENT : constant := 9; - - begin - Trace_Output ("Looking for Event: "); - Trace_Output (Unsigned_Longword'Image (Event_Code)); - - for I in Event_Kind_Type'Range loop - if Event_Code = Unsigned_Longword (Event_Directory (I).Code) then - Event_Entry := To_UL (Event_Directory (I)'Address); - Trace_Output ("Found Event # "); - Trace_Output (Integer'Image (I)); - Status := K_SUCCESS; - return; - end if; - end loop; - - Status := K_NO_SUCH_EVENT; - end Find_Event_By_Code; - - ------------------------ - -- Find_Event_By_Name -- - ------------------------ - - procedure Find_Event_By_Name - (Event_Name : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type) - is - K_SUCCESS : constant := 1; - K_NO_SUCH_EVENT : constant := 9; - - Event_Name_Cstr : constant ASCIC := To_AASCIC (Event_Name).all; - begin - Trace_Output ("Looking for Event: "); - Trace_Output (Event_Name_Cstr.Text); - - for I in Event_Kind_Type'Range loop - if Event_Name_Cstr.Count >= Event_Directory (I).Minchr - and then Event_Name_Cstr.Count <= Event_Directory (I).Name.Count - and then Event_Name_Cstr.Text (1 .. Event_Directory (I).Minchr) = - Event_Directory (I).Name.Text (1 .. Event_Directory (I).Minchr) - then - Event_Entry := To_UL (Event_Directory (I)'Address); - Trace_Output ("Found Event # "); - Trace_Output (Integer'Image (I)); - Status := K_SUCCESS; - return; - end if; - end loop; - - Status := K_NO_SUCH_EVENT; - end Find_Event_By_Name; - - -------------------- - -- Get_User_State -- - -------------------- - - function Get_User_State return Long_Integer is - begin - return STPO.Self.User_State; - end Get_User_State; - - ------------------------ - -- List_Entry_Waiters -- - ------------------------ - - procedure List_Entry_Waiters - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - pragma Unreferenced (Suppress_Header); - - Entry_Call : Entry_Call_Link; - Have_Some : Boolean := False; - begin - if not Full_Display then - return; - end if; - - if Task_Value.Entry_Queues'Length > 0 then - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Waiting entry callers:"))); - end if; - for I in Task_Value.Entry_Queues'Range loop - Entry_Call := Task_Value.Entry_Queues (I).Head; - if Entry_Call /= null then - Have_Some := True; - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Waiters for entry !UI:")), - To_UL (I)); - - loop - declare - Task_Image : ASCIC := - (Entry_Call.Self.Common.Task_Image_Len, - Entry_Call.Self.Common.Task_Image - (1 .. Entry_Call.Self.Common.Task_Image_Len)); - begin - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" %TASK !UI, type: !AC")), - To_UL (Entry_Call.Self.Known_Tasks_Index + 1), - To_UL (Task_Image'Address)); - if Entry_Call = Task_Value.Entry_Queues (I).Tail then - exit; - end if; - Entry_Call := Entry_Call.Next; - end; - end loop; - end if; - end loop; - if not Have_Some then - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" none."))); - end if; - end List_Entry_Waiters; - - ---------------- - -- List_Tasks -- - ---------------- - - procedure List_Tasks is - C : Task_Id; - begin - C := All_Tasks_List; - - while C /= null loop - Print_Task_Info (C); - C := C.Common.All_Tasks_Link; - end loop; - end List_Tasks; - - ------------------------ - -- Print_Current_Task -- - ------------------------ - - procedure Print_Current_Task is - begin - Print_Task_Info (STPO.Self); - end Print_Current_Task; - - --------------------- - -- Print_Task_Info -- - --------------------- - - procedure Print_Task_Info (T : Task_Id) is - Entry_Call : Entry_Call_Link; - Parent : Task_Id; - - begin - if T = null then - Put_Line ("null task"); - return; - end if; - - Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " & - Task_States'Image (T.Common.State)); - - Parent := T.Common.Parent; - - if Parent = null then - Put (", parent: "); - else - Put (", parent: " & - Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len)); - end if; - - Put (", prio:" & T.Common.Current_Priority'Img); - - if not T.Callable then - Put (", not callable"); - end if; - - if T.Aborting then - Put (", aborting"); - end if; - - if T.Deferral_Level /= 0 then - Put (", abort deferred"); - end if; - - if T.Common.Call /= null then - Entry_Call := T.Common.Call; - Put (", serving:"); - - while Entry_Call /= null loop - Put (To_Integer (Entry_Call.Self)'Img); - Entry_Call := Entry_Call.Acceptor_Prev_Call; - end loop; - end if; - - if T.Open_Accepts /= null then - Put (", accepting:"); - - for J in T.Open_Accepts'Range loop - Put (T.Open_Accepts (J).S'Img); - end loop; - - if T.Terminate_Alternative then - Put (" or terminate"); - end if; - end if; - - if T.User_State /= 0 then - Put (", state:" & T.User_State'Img); - end if; - - Put_Line; - end Print_Task_Info; - - --------- - -- Put -- - --------- - - procedure Put (S : String) is - begin - Write (2, S, S'Length); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (S : String := "") is - begin - Write (2, S & ASCII.LF, S'Length + 1); - end Put_Line; - - ---------------------- - -- Resume_All_Tasks -- - ---------------------- - - procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is - pragma Unreferenced (Thread_Self); - begin - null; -- VxWorks - end Resume_All_Tasks; - - --------------- - -- Set_Trace -- - --------------- - - procedure Set_Trace (Flag : Character; Value : Boolean := True) is - begin - Trace_On (Flag) := Value; - end Set_Trace; - - -------------------- - -- Set_User_State -- - -------------------- - - procedure Set_User_State (Value : Long_Integer) is - begin - STPO.Self.User_State := Value; - end Set_User_State; - - ---------------- - -- Show_Event -- - ---------------- - - procedure Show_Event - (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - begin - for I in Event_Def_Help'Range loop - Print_Routine (Print_FAO, Print_Newline, To_UL (Event_Def_Help (I))); - end loop; - - for I in Event_Kind_Type'Range loop - Print_Routine (Print_FAO, Print_Newline, - To_UL (Event_Directory - (Global_Event_Display_Order (I)).Name'Address)); - Print_Routine (Print_FAO, Print_Newline, - To_UL (Event_Directory (Global_Event_Display_Order (I)).Help)); - end loop; - end Show_Event; - - -------------------- - -- Show_One_Task -- - -------------------- - - procedure Show_One_Task - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - Task_SP : System.Address := Address_Zero; - Stack_Base : System.Address := Address_Zero; - Stack_Top : System.Address := Address_Zero; - TCB_Size : Unsigned_Longword := 0; - CMA_TCB_Size : Unsigned_Longword := 0; - Stack_Guard_Size : Unsigned_Longword := 0; - Total_Task_Storage : Unsigned_Longword := 0; - Stack_In_Use : Unsigned_Longword := 0; - Reserved_Size : Unsigned_Longword := 0; - Hold_Flag : Unsigned_Longword := 0; - Sched_State : Unsigned_Longword := 0; - User_Prio : Unsigned_Longword := 0; - Stack_Size : Unsigned_Longword := 0; - Run_State : Boolean := False; - Rea_State : Boolean := False; - Sus_State : Boolean := False; - Ter_State : Boolean := False; - - Current_Flag : AASCIC := NoStar; - Hold_String : AASCIC := NoHold; - Ada_State : AASCIC := Ada_State_Invalid_State; - Debug_State : AASCIC := Debug_State_Emp; - - Ada_State_Len : constant Unsigned_Longword := 17; - Debug_State_Len : constant Unsigned_Longword := 5; - - Entry_Call : Entry_Call_Record; - - begin - - -- Initialize local task info variables - - Task_SP := Address_Zero; - Stack_Base := Address_Zero; - Stack_Top := Address_Zero; - CMA_TCB_Size := 0; - Stack_Guard_Size := 0; - Reserved_Size := 0; - Hold_Flag := 0; - Sched_State := 0; - TCB_Size := Unsigned_Longword (Task_Id'Size); - - if not Suppress_Header or else Full_Display then - Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); - Print_Routine (Print_FAO, Print_Newline, To_UL (Header)); - end if; - - Trace_Output ("Show_One_Task Task Value: "); - Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value))); - - -- Callback to DEBUG to get some task info - - if Task_Value.Common.State /= Terminated then - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_STACKPTR, - Task_SP, - 8); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_TCB_SIZE, - CMA_TCB_Size, - 4); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_GUARDSIZE, - Stack_Guard_Size, - 4); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_YELLOWSIZE, - Reserved_Size, - 4); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_STACK_BASE, - Stack_Base, - 8); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_STACK_TOP, - Stack_Top, - 8); - - Stack_Size := Unsigned_Longword (Stack_Base - Stack_Top) - - Reserved_Size - Stack_Guard_Size; - Stack_In_Use := Unsigned_Longword (Stack_Base - Task_SP) + 4; - Total_Task_Storage := TCB_Size + Stack_Size + Stack_Guard_Size - + Reserved_Size + CMA_TCB_Size; - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_IS_HELD, - Hold_Flag, - 4); - - Hold_String := (if Hold_Flag /= 0 then Hold else NoHold); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_SCHED_STATE, - Sched_State, - 4); - end if; - - Run_State := False; - Rea_State := False; - Sus_State := Task_Value.Common.State = Unactivated; - Ter_State := Task_Value.Common.State = Terminated; - - if not Ter_State then - Run_State := Sched_State = 0; - Rea_State := Sched_State = 1; - Sus_State := Sched_State /= 0 and Sched_State /= 1; - end if; - - -- Set the debug state - - if Run_State then - Debug_State := Debug_State_Run; - elsif Rea_State then - Debug_State := Debug_State_Rea; - elsif Sus_State then - Debug_State := Debug_State_Sus; - elsif Ter_State then - Debug_State := Debug_State_Ter; - end if; - - Trace_Output ("Before case State: "); - Trace_Output (Task_States'Image (Task_Value.Common.State)); - - -- Set the Ada state - - case Task_Value.Common.State is - when Unactivated => - Ada_State := Ada_State_Not_Yet_Activated; - - when Activating => - Ada_State := Ada_State_Activating; - - when Runnable => - Ada_State := Ada_State_Runnable; - - when Terminated => - Ada_State := Ada_State_Terminated; - - when Activator_Sleep => - Ada_State := Ada_State_Activating_Tasks; - - when Acceptor_Sleep => - Ada_State := Ada_State_Accept; - - when Acceptor_Delay_Sleep => - Ada_State := Ada_State_Select_or_Delay; - - when Entry_Caller_Sleep => - Entry_Call := - Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level); - - case Entry_Call.Mode is - when Simple_Call => - Ada_State := Ada_State_Entry_Call; - when Conditional_Call => - Ada_State := Ada_State_Cond_Entry_Call; - when Timed_Call => - Ada_State := Ada_State_Timed_Entry_Call; - when Asynchronous_Call => - Ada_State := Ada_State_Async_Entry_Call; - end case; - - when Async_Select_Sleep => - Ada_State := Ada_State_Select_or_Abort; - - when Delay_Sleep => - Ada_State := Ada_State_Delay; - - when Master_Completion_Sleep => - Ada_State := Ada_State_Completed; - - when Master_Phase_2_Sleep => - Ada_State := Ada_State_Completed; - - when Interrupt_Server_Idle_Sleep | - Interrupt_Server_Blocked_Interrupt_Sleep | - Timer_Server_Sleep | - Interrupt_Server_Blocked_On_Event_Flag => - Ada_State := Ada_State_Server; - - when AST_Server_Sleep => - Ada_State := Ada_State_IO_or_AST; - - when Asynchronous_Hold => - Ada_State := Ada_State_Async_Hold; - - end case; - - if Task_Value.Terminate_Alternative then - Ada_State := Ada_State_Select_or_Term; - end if; - - if Task_Value.Aborting then - Ada_State := Ada_State_Aborting; - end if; - - User_Prio := To_UL (Task_Value.Common.Current_Priority); - Trace_Output ("After user_prio"); - - -- Flag the current task - - Current_Flag := (if Task_Value = Self then Star else NoStar); - - -- Show task info - - Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!AC%TASK !5")), - To_UL (Current_Flag), To_UL (Task_Value.Known_Tasks_Index + 1)); - - Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!2UB")), User_Prio); - - Print_Routine (Print_FAO, No_Print, To_UL (DoAC (" !AC !5AD !17AD ")), - To_UL (Hold_String), Debug_State_Len, To_UL (Debug_State), - Ada_State_Len, To_UL (Ada_State)); - --- Print_Routine (Print_Symbol, Print_Newline, --- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point))); - - Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); - - -- If /full qualfier passed, show detailed info - - if Full_Display then - Show_Rendezvous (Task_Value, Ada_State, Full_Display, - Suppress_Header, Print_Routine); - - List_Entry_Waiters (Task_Value, Full_Display, - Suppress_Header, Print_Routine); - - Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); - - declare - Task_Image : ASCIC := (Task_Value.Common.Task_Image_Len, - Task_Value.Common.Task_Image - (1 .. Task_Value.Common.Task_Image_Len)); - begin - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Task type: !AC")), - To_UL (Task_Image'Address)); - end; - - -- How to find Creation_PC ??? --- Print_Routine (Print_FAO, No_Print, --- To_UL (DoAC (" Created at PC: ")), --- Print_Routine (Print_FAO, Print_Newline, Creation_PC); - - if Task_Value.Common.Parent /= null then - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Parent task: %TASK !UI")), - To_UL (Task_Value.Common.Parent.Known_Tasks_Index + 1)); - else - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Parent task: none"))); - end if; - --- Print_Routine (Print_FAO, No_Print, --- To_UL (DoAC (" Start PC: "))); --- Print_Routine (Print_Symbol, Print_Newline, --- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point))); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Task control block: Stack storage (bytes):"))); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Task value: !10 RESERVED_BYTES: !10UI")), - To_UL (Task_Value), Reserved_Size); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Entries: !10 TOP_GUARD_SIZE: !10UI")), - To_UL (Task_Value.Entry_Num), Stack_Guard_Size); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Size: !10 STORAGE_SIZE: !10UI")), - TCB_Size + CMA_TCB_Size, Stack_Size); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Stack addresses: Bytes in use: !10UI")), - Stack_In_Use); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Top address: !10")), - To_UL (Stack_Top)); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Base address: !10 Total storage: !10UI")), - To_UL (Stack_Base), Total_Task_Storage); - end if; - - end Show_One_Task; - - --------------------- - -- Show_Rendezvous -- - --------------------- - - procedure Show_Rendezvous - (Task_Value : Task_Id; - Ada_State : AASCIC := Empty_Text; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - pragma Unreferenced (Ada_State); - pragma Unreferenced (Suppress_Header); - - Temp_Entry : Entry_Index; - Entry_Call : Entry_Call_Record; - Called_Task : Task_Id; - AWR : constant String := " Awaiting rendezvous at: "; - -- Common prefix - - procedure Print_Accepts; - -- Display information about task rendezvous accepts - - procedure Print_Accepts is - begin - if Task_Value.Open_Accepts /= null then - for I in Task_Value.Open_Accepts'Range loop - Temp_Entry := Entry_Index (Task_Value.Open_Accepts (I).S); - declare - Entry_Name_Image : ASCIC := - (Task_Value.Entry_Names (Temp_Entry).all'Length, - Task_Value.Entry_Names (Temp_Entry).all); - begin - Trace_Output ("Accept at: " & Entry_Name_Image.Text); - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" accept at: !AC")), - To_UL (Entry_Name_Image'Address)); - end; - end loop; - end if; - end Print_Accepts; - begin - if not Full_Display then - return; - end if; - - Trace_Output ("Show_Rendezvous Task Value: "); - Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value))); - - if Task_Value.Common.State = Acceptor_Sleep and then - not Task_Value.Terminate_Alternative - then - if Task_Value.Open_Accepts /= null then - Temp_Entry := Entry_Index (Task_Value.Open_Accepts - (Task_Value.Open_Accepts'First).S); - declare - Entry_Name_Image : ASCIC := - (Task_Value.Entry_Names (Temp_Entry).all'Length, - Task_Value.Entry_Names (Temp_Entry).all); - begin - Trace_Output (AWR & "accept " & Entry_Name_Image.Text); - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "accept !AC")), - To_UL (Entry_Name_Image'Address)); - end; - - else - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" entry name unavailable"))); - end if; - else - case Task_Value.Common.State is - when Acceptor_Sleep => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "select with terminate."))); - Print_Accepts; - - when Async_Select_Sleep => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "select."))); - Print_Accepts; - - when Acceptor_Delay_Sleep => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "select with delay."))); - Print_Accepts; - - when Entry_Caller_Sleep => - Entry_Call := - Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level); - - case Entry_Call.Mode is - when Simple_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call"))); - when Conditional_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call with else"))); - when Timed_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call with delay"))); - when Asynchronous_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call with abort"))); - end case; - Called_Task := Entry_Call.Called_Task; - declare - Task_Image : ASCIC := (Called_Task.Common.Task_Image_Len, - Called_Task.Common.Task_Image - (1 .. Called_Task.Common.Task_Image_Len)); - Entry_Name_Image : ASCIC := - (Called_Task.Entry_Names (Entry_Call.E).all'Length, - Called_Task.Entry_Names (Entry_Call.E).all); - begin - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC - (" for entry !AC in %TASK !UI type !AC")), - To_UL (Entry_Name_Image'Address), - To_UL (Called_Task.Known_Tasks_Index), - To_UL (Task_Image'Address)); - end; - - when others => - return; - end case; - end if; - - end Show_Rendezvous; - - ------------------------ - -- Signal_Debug_Event -- - ------------------------ - - procedure Signal_Debug_Event - (Event_Kind : Event_Kind_Type; Task_Value : Task_Id) - is - Do_Signal : Boolean; - EVCB : Ada_Event_Control_Block_Access; - - EVCB_Sent : constant := 16#9B#; - Ada_Facility : constant := 49; - SS_DBGEVENT : constant := 1729; - begin - Do_Signal := Global_Task_Debug_Events (Event_Kind); - - if not Do_Signal then - if Task_Value /= null then - Do_Signal := Do_Signal - or else Task_Value.Common.Debug_Events (Event_Kind); - end if; - end if; - - if Do_Signal then - -- Build an a tasking event control block and signal DEBUG - - EVCB := new Ada_Event_Control_Block_Type; - EVCB.Code := Unsigned_Word (Event_Kind); - EVCB.Sentinal := EVCB_Sent; - EVCB.Facility := Ada_Facility; - - if Task_Value /= null then - EVCB.Value := Unsigned_Longword (Task_Value.Known_Tasks_Index + 1); - else - EVCB.Value := 0; - end if; - - EVCB.Sub_Event := 0; - EVCB.P1 := 0; - EVCB.Sigargs := 0; - EVCB.Flags := 0; - EVCB.Unused1 := 0; - EVCB.Unused2 := 0; - - Signal (SS_DBGEVENT, 1, To_UL (EVCB)); - end if; - end Signal_Debug_Event; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - begin - null; -- VxWorks - end Stop_All_Tasks; - - ---------------------------- - -- Stop_All_Tasks_Handler -- - ---------------------------- - - procedure Stop_All_Tasks_Handler is - begin - null; -- VxWorks - end Stop_All_Tasks_Handler; - - ----------------------- - -- Suspend_All_Tasks -- - ----------------------- - - procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is - pragma Unreferenced (Thread_Self); - begin - null; -- VxWorks - end Suspend_All_Tasks; - - ------------------------ - -- Task_Creation_Hook -- - ------------------------ - - procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is - pragma Unreferenced (Thread); - begin - null; -- VxWorks - end Task_Creation_Hook; - - --------------------------- - -- Task_Termination_Hook -- - --------------------------- - - procedure Task_Termination_Hook is - begin - null; -- VxWorks - end Task_Termination_Hook; - - ----------- - -- Trace -- - ----------- - - procedure Trace - (Self_Id : Task_Id; - Msg : String; - Flag : Character; - Other_Id : Task_Id := null) - is - begin - if Trace_On (Flag) then - Put (To_Integer (Self_Id)'Img & - ':' & Flag & ':' & - Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) & - ':'); - - if Other_Id /= null then - Put (To_Integer (Other_Id)'Img & ':'); - end if; - - Put_Line (Msg); - end if; - end Trace; - - ------------------ - -- Trace_Output -- - ------------------ - - procedure Trace_Output (Message_String : String) is - begin - if Trace_On ('V') and Trace_On ('M') and Trace_On ('S') then - Put_Output (Message_String); - end if; - end Trace_Output; - - ----------- - -- Write -- - ----------- - - procedure Write (Fd : Integer; S : String; Count : Integer) is - Discard : System.CRTL.ssize_t; - pragma Unreferenced (Discard); - begin - Discard := System.CRTL.write (Fd, S (S'First)'Address, - System.CRTL.size_t (Count)); - -- Is it really right to ignore write errors here ??? - end Write; - -end System.Tasking.Debug; diff --git a/main/gcc/ada/s-tasdeb.adb b/main/gcc/ada/s-tasdeb.adb index 2c8b638493c..a18b844bcba 100644 --- a/main/gcc/ada/s-tasdeb.adb +++ b/main/gcc/ada/s-tasdeb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2014, 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- -- @@ -37,8 +37,14 @@ -- Do not add any dependency to GNARL packages since this package is used -- in both normal and restricted (ravenscar) environments. -with System.Address_Image; +pragma Restriction_Warnings (No_Secondary_Stack); +-- We wish to avoid secondary stack usage here, because (e.g.) Trace is called +-- at delicate times, such as during task termination after the secondary +-- stack has been deallocated. It's just a warning, so we don't require +-- partition-wide consistency. + with System.CRTL; +with System.Storage_Elements; use System.Storage_Elements; with System.Task_Primitives; with System.Task_Primitives.Operations; @@ -66,21 +72,19 @@ package body System.Tasking.Debug is procedure Put_Line (S : String := ""); -- Display S on standard error with an additional line terminator - function Task_Image (T : Task_Id) return String; - -- Return the relevant characters from T.Common.Task_Image + procedure Put_Task_Image (T : Task_Id); + -- Display relevant characters from T.Common.Task_Image on standard error - function Task_Id_Image (T : Task_Id) return String; - -- Return the address in hexadecimal form + procedure Put_Task_Id_Image (T : Task_Id); + -- Display address in hexadecimal form on standard error ------------------------ -- Continue_All_Tasks -- ------------------------ procedure Continue_All_Tasks is - C : Task_Id; - + C : Task_Id; Dummy : Boolean; - pragma Unreferenced (Dummy); begin STPO.Lock_RTS; @@ -111,7 +115,6 @@ package body System.Tasking.Debug is C : Task_Id; begin C := All_Tasks_List; - while C /= null loop Print_Task_Info (C); C := C.Common.All_Tasks_Link; @@ -141,13 +144,15 @@ package body System.Tasking.Debug is return; end if; - Put (Task_Image (T) & ": " & Task_States'Image (T.Common.State)); + Put_Task_Image (T); + Put (": " & Task_States'Image (T.Common.State)); Parent := T.Common.Parent; if Parent = null then Put (", parent: "); else - Put (", parent: " & Task_Image (Parent)); + Put (", parent: "); + Put_Task_Image (Parent); end if; Put (", prio:" & T.Common.Current_Priority'Img); @@ -169,7 +174,7 @@ package body System.Tasking.Debug is Put (", serving:"); while Entry_Call /= null loop - Put (Task_Id_Image (Entry_Call.Self)); + Put_Task_Id_Image (Entry_Call.Self); Entry_Call := Entry_Call.Acceptor_Prev_Call; end loop; end if; @@ -211,6 +216,66 @@ package body System.Tasking.Debug is Write (Stderr_Fd, S & ASCII.LF, S'Length + 1); end Put_Line; + ----------------------- + -- Put_Task_Id_Image -- + ----------------------- + + procedure Put_Task_Id_Image (T : Task_Id) is + Address_Image_Length : constant := + 13 + (if Standard'Address_Size = 64 then 10 else 0); + -- Length of string to be printed for address of task + + H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + -- Table of hex digits + + S : String (1 .. Address_Image_Length); + P : Natural; + N : Integer_Address; + U : Natural := 0; + + begin + if T = null then + Put ("Null_Task_Id"); + + else + S (S'Last) := '#'; + P := Address_Image_Length - 1; + N := To_Integer (T.all'Address); + while P > 3 loop + if U = 4 then + S (P) := '_'; + P := P - 1; + U := 1; + else + U := U + 1; + end if; + + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + end loop; + + S (1 .. 3) := "16#"; + Put (S); + end if; + end Put_Task_Id_Image; + + -------------------- + -- Put_Task_Image -- + -------------------- + + procedure Put_Task_Image (T : Task_Id) is + begin + -- In case T.Common.Task_Image_Len is uninitialized junk, we check that + -- it is in range, to make this more robust. + + if T.Common.Task_Image_Len in T.Common.Task_Image'Range then + Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); + else + Put (T.Common.Task_Image); + end if; + end Put_Task_Image; + ---------------------- -- Resume_All_Tasks -- ---------------------- @@ -218,12 +283,11 @@ package body System.Tasking.Debug is procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is C : Task_Id; Dummy : Boolean; - pragma Unreferenced (Dummy); begin STPO.Lock_RTS; - C := All_Tasks_List; + C := All_Tasks_List; while C /= null loop Dummy := STPO.Resume_Task (C, Thread_Self); C := C.Common.All_Tasks_Link; @@ -267,10 +331,8 @@ package body System.Tasking.Debug is -------------------- procedure Stop_All_Tasks is - C : Task_Id; - + C : Task_Id; Dummy : Boolean; - pragma Unreferenced (Dummy); begin STPO.Lock_RTS; @@ -300,12 +362,11 @@ package body System.Tasking.Debug is procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is C : Task_Id; Dummy : Boolean; - pragma Unreferenced (Dummy); begin STPO.Lock_RTS; - C := All_Tasks_List; + C := All_Tasks_List; while C /= null loop Dummy := STPO.Suspend_Task (C, Thread_Self); C := C.Common.All_Tasks_Link; @@ -327,35 +388,6 @@ package body System.Tasking.Debug is null; end Task_Creation_Hook; - ---------------- - -- Task_Id_Image -- - ---------------- - - function Task_Id_Image (T : Task_Id) return String is - begin - if T = null then - return "Null_Task_Id"; - else - return Address_Image (T.all'Address); - end if; - end Task_Id_Image; - - ---------------- - -- Task_Image -- - ---------------- - - function Task_Image (T : Task_Id) return String is - begin - -- In case T.Common.Task_Image_Len is uninitialized junk, we check that - -- it is in range, to make this more robust. - - if T.Common.Task_Image_Len in T.Common.Task_Image'Range then - return T.Common.Task_Image (1 .. T.Common.Task_Image_Len); - else - return T.Common.Task_Image; - end if; - end Task_Image; - --------------------------- -- Task_Termination_Hook -- --------------------------- @@ -377,13 +409,14 @@ package body System.Tasking.Debug is is begin if Trace_On (Flag) then - Put (Task_Id_Image (Self_Id) & - ':' & Flag & ':' & - Task_Image (Self_Id) & - ':'); + Put_Task_Id_Image (Self_Id); + Put (":" & Flag & ":"); + Put_Task_Image (Self_Id); + Put (":"); if Other_Id /= null then - Put (Task_Id_Image (Other_Id) & ':'); + Put_Task_Id_Image (Other_Id); + Put (":"); end if; Put_Line (Msg); @@ -396,12 +429,42 @@ package body System.Tasking.Debug is procedure Write (Fd : Integer; S : String; Count : Integer) is Discard : System.CRTL.ssize_t; - pragma Unreferenced (Discard); - begin - Discard := System.CRTL.write (Fd, S'Address, - System.CRTL.size_t (Count)); -- Ignore write errors here; this is just debugging output, and there's -- nothing to be done about errors anyway. + begin + Discard := + System.CRTL.write + (Fd, S'Address, System.CRTL.size_t (Count)); end Write; + ----------------- + -- Master_Hook -- + ----------------- + + procedure Master_Hook + (Dependent : Task_Id; + Parent : Task_Id; + Master_Level : Integer) + is + pragma Inspection_Point (Dependent); + pragma Inspection_Point (Parent); + pragma Inspection_Point (Master_Level); + begin + null; + end Master_Hook; + + --------------------------- + -- Master_Completed_Hook -- + --------------------------- + + procedure Master_Completed_Hook + (Self_ID : Task_Id; + Master_Level : Integer) + is + pragma Inspection_Point (Self_ID); + pragma Inspection_Point (Master_Level); + begin + null; + end Master_Completed_Hook; + end System.Tasking.Debug; diff --git a/main/gcc/ada/s-tasdeb.ads b/main/gcc/ada/s-tasdeb.ads index 0d0df436ad6..e0bd0c1e01a 100644 --- a/main/gcc/ada/s-tasdeb.ads +++ b/main/gcc/ada/s-tasdeb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2014, 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- -- @@ -105,25 +105,25 @@ package System.Tasking.Debug is procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id); -- Suspend all the tasks except the one whose associated thread is - -- Thread_Self by traversing All_Tasks_Lists and calling + -- Thread_Self by traversing All_Tasks_List and calling -- System.Task_Primitives.Operations.Suspend_Task. procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id); -- Resume all the tasks except the one whose associated thread is - -- Thread_Self by traversing All_Tasks_Lists and calling + -- Thread_Self by traversing All_Tasks_List and calling -- System.Task_Primitives.Operations.Continue_Task. procedure Stop_All_Tasks_Handler; - -- Stop all the tasks by traversing All_Tasks_Lists and calling + -- Stop all the tasks by traversing All_Tasks_List and calling -- System.Task_Primitives.Operations.Stop_All_Task. This function -- can be used in an interrupt handler. procedure Stop_All_Tasks; - -- Stop all the tasks by traversing All_Tasks_Lists and calling + -- Stop all the tasks by traversing All_Tasks_List and calling -- System.Task_Primitives.Operations.Stop_Task. procedure Continue_All_Tasks; - -- Continue all the tasks by traversing All_Tasks_Lists and calling + -- Continue all the tasks by traversing All_Tasks_List and calling -- System.Task_Primitives.Operations.Continue_Task. ------------------------------- @@ -145,4 +145,21 @@ package System.Tasking.Debug is -- Enable or disable tracing for Flag. By default, flags in the range -- 'A' .. 'Z' are disabled, others are enabled. + --------------------------------- + -- Hooks for Valgrind/Helgrind -- + --------------------------------- + + procedure Master_Hook + (Dependent : Task_Id; + Parent : Task_Id; + Master_Level : Integer); + -- Indicate to Valgrind/Helgrind that the master of Dependent is + -- Parent + Master_Level. + + procedure Master_Completed_Hook + (Self_ID : Task_Id; + Master_Level : Integer); + -- Indicate to Valgrind/Helgrind that Self_ID has completed the master + -- Master_Level. + end System.Tasking.Debug; diff --git a/main/gcc/ada/s-tasinf.adb b/main/gcc/ada/s-tasinf.adb index 905af8605e6..d48d163a13e 100644 --- a/main/gcc/ada/s-tasinf.adb +++ b/main/gcc/ada/s-tasinf.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Compiler Interface) -- -- -- --- Copyright (C) 1998-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-tasini.adb b/main/gcc/ada/s-tasini.adb index 45c99cdadce..871ab5abcce 100644 --- a/main/gcc/ada/s-tasini.adb +++ b/main/gcc/ada/s-tasini.adb @@ -45,6 +45,7 @@ with System.Task_Primitives.Operations; with System.Soft_Links; with System.Soft_Links.Tasking; with System.Tasking.Debug; +with System.Tasking.Task_Attributes; with System.Parameters; with System.Secondary_Stack; @@ -509,7 +510,7 @@ package body System.Tasking.Initialization is -- The task is blocked on a system call waiting for the -- completion event. In this case Abort_Task may need to take - -- special action in order to succeed. Example system: VMS. + -- special action in order to succeed. then Abort_Task (T); @@ -807,26 +808,23 @@ package body System.Tasking.Initialization is end if; end Wakeup_Entry_Caller; - ----------------------- - -- Soft-Link Dummies -- - ----------------------- - - -- These are dummies for subprograms that are only needed by certain - -- optional run-time system packages. If they are needed, the soft links - -- will be redirected to the real subprogram by elaboration of the - -- subprogram body where the real subprogram is declared. + ------------------------- + -- Finalize_Attributes -- + ------------------------- procedure Finalize_Attributes (T : Task_Id) is - pragma Unreferenced (T); - begin - null; - end Finalize_Attributes; + Attr : Atomic_Address; - procedure Initialize_Attributes (T : Task_Id) is - pragma Unreferenced (T); begin - null; - end Initialize_Attributes; + for J in T.Attributes'Range loop + Attr := T.Attributes (J); + + if Attr /= 0 and then Task_Attributes.Require_Finalization (J) then + Task_Attributes.To_Attribute (Attr).Free (Attr); + T.Attributes (J) := 0; + end if; + end loop; + end Finalize_Attributes; begin Init_RTS; diff --git a/main/gcc/ada/s-tasini.ads b/main/gcc/ada/s-tasini.ads index 70dd867a342..29f10e06133 100644 --- a/main/gcc/ada/s-tasini.ads +++ b/main/gcc/ada/s-tasini.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -37,27 +37,15 @@ package System.Tasking.Initialization is procedure Remove_From_All_Tasks_List (T : Task_Id); -- Remove T from All_Tasks_List. Call this function with RTS_Lock taken + procedure Finalize_Attributes (T : Task_Id); + -- Finalize all attributes from T. This is to be called just before the + -- ATCB is deallocated. It relies on the caller holding T.L write-lock + -- on entry. + --------------------------------- -- Tasking-Specific Soft Links -- --------------------------------- - -- These permit us to leave out certain portions of the tasking - -- run-time system if they are not used. They are only used internally - -- by the tasking run-time system. - - -- So far, the only example is support for Ada.Task_Attributes - - type Proc_T is access procedure (T : Task_Id); - - procedure Finalize_Attributes (T : Task_Id); - procedure Initialize_Attributes (T : Task_Id); - - Finalize_Attributes_Link : Proc_T := Finalize_Attributes'Access; - -- should be called with abort deferred and T.L write-locked - - Initialize_Attributes_Link : Proc_T := Initialize_Attributes'Access; - -- should be called with abort deferred, but holding no locks - ------------------------- -- Abort Defer/Undefer -- ------------------------- diff --git a/main/gcc/ada/s-taskin.ads b/main/gcc/ada/s-taskin.ads index 8f1bb05feb0..761bd2b629a 100644 --- a/main/gcc/ada/s-taskin.ads +++ b/main/gcc/ada/s-taskin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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,8 +86,10 @@ package System.Tasking is -- Sometimes we need to hold two ATCB locks at the same time. To allow us -- to order the locking, each ATCB is given a unique serial number. If one - -- needs to hold locks on several ATCBs at once, the locks with lower - -- serial numbers must be locked first. + -- needs to hold locks on two ATCBs at once, the lock with lower serial + -- number must be locked first. We avoid holding three or more ATCB locks, + -- because that can easily lead to complications that cause race conditions + -- and deadlocks. -- We don't always need to check the serial numbers, since the serial -- numbers are assigned sequentially, and so: @@ -936,22 +938,13 @@ package System.Tasking is type Entry_Call_Array is array (ATC_Level_Index) of aliased Entry_Call_Record; - type Direct_Index is range 0 .. Parameters.Default_Attribute_Count; - subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last; - -- Attributes with indexes in this range are stored directly in the task - -- control block. Such attributes must be Address-sized. Other attributes - -- will be held in dynamically allocated records chained off of the task - -- control block. - - type Direct_Attribute_Element is mod Memory_Size; - pragma Atomic (Direct_Attribute_Element); - - type Direct_Attribute_Array is - array (Direct_Index_Range) of aliased Direct_Attribute_Element; - - type Direct_Index_Vector is mod 2 ** Parameters.Default_Attribute_Count; - -- This is a bit-vector type, used to store information about - -- the usage of the direct attribute fields. + type Atomic_Address is mod Memory_Size; + pragma Atomic (Atomic_Address); + type Attribute_Array is + array (1 .. Parameters.Max_Attribute_Count) of Atomic_Address; + -- Array of task attributes. The value (Atomic_Address) will either be + -- converted to a task attribute if it fits, or to a pointer to a record + -- by Ada.Task_Attributes. type Task_Serial_Number is mod 2 ** 64; -- Used to give each task a unique serial number @@ -1137,15 +1130,8 @@ package System.Tasking is -- User-writeable location, for use in debugging tasks; also provides a -- simple task specific data. - Direct_Attributes : Direct_Attribute_Array; - -- For task attributes that have same size as Address - - Is_Defined : Direct_Index_Vector := 0; - -- Bit I is 1 iff Direct_Attributes (I) is defined - - Indirect_Attributes : Access_Address; - -- A pointer to chain of records for other attributes that are not - -- address-sized, including all tagged types. + Attributes : Attribute_Array := (others => 0); + -- Task attributes Entry_Queues : Task_Entry_Queue_Array (1 .. Entry_Num); -- An array of task entry queues diff --git a/main/gcc/ada/s-taspri-dummy.ads b/main/gcc/ada/s-taspri-dummy.ads index 5fe9fa34277..271f5d1c301 100644 --- a/main/gcc/ada/s-taspri-dummy.ads +++ b/main/gcc/ada/s-taspri-dummy.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2014, 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- -- @@ -53,13 +53,8 @@ package System.Task_Primitives is end record; subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := 0; -- No alternate signal stack is used on this platform diff --git a/main/gcc/ada/s-taspri-hpux-dce.ads b/main/gcc/ada/s-taspri-hpux-dce.ads index 8010c2a5b2b..137f34b8aed 100644 --- a/main/gcc/ada/s-taspri-hpux-dce.ads +++ b/main/gcc/ada/s-taspri-hpux-dce.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2014, 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- -- @@ -63,13 +63,8 @@ package System.Task_Primitives is -- Ada_Task_Control_Block. subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := 0; -- No alternate signal stack is used on this platform diff --git a/main/gcc/ada/s-taspri-mingw.ads b/main/gcc/ada/s-taspri-mingw.ads index cc4f4019fa9..a4306254144 100644 --- a/main/gcc/ada/s-taspri-mingw.ads +++ b/main/gcc/ada/s-taspri-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2014, 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,13 +62,8 @@ package System.Task_Primitives is -- Ada_Task_Control_Block. subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := 0; -- No alternate signal stack is used on this platform diff --git a/main/gcc/ada/s-taspri-posix-noaltstack.ads b/main/gcc/ada/s-taspri-posix-noaltstack.ads index ac0e743af8f..a7708b2b300 100644 --- a/main/gcc/ada/s-taspri-posix-noaltstack.ads +++ b/main/gcc/ada/s-taspri-posix-noaltstack.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, AdaCore -- +-- Copyright (C) 1995-2014, 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- -- @@ -65,13 +65,8 @@ package System.Task_Primitives is -- Ada_Task_Control_Block. subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := 0; -- No alternate signal stack is used on this platform diff --git a/main/gcc/ada/s-taspri-posix.ads b/main/gcc/ada/s-taspri-posix.ads index 9f40693aa74..7eb0781569d 100644 --- a/main/gcc/ada/s-taspri-posix.ads +++ b/main/gcc/ada/s-taspri-posix.ads @@ -7,7 +7,7 @@ -- S p e c -- -- -- -- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2011, AdaCore -- +-- Copyright (C) 1995-2014, 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- -- @@ -48,8 +48,8 @@ package System.Task_Primitives is type RTS_Lock is limited private; -- Should be used inside the runtime system. The difference between Lock - -- and the RTS_Lock is that the later one serves only as a semaphore so - -- that do not check for ceiling violations. + -- and the RTS_Lock is that the latter serves only as a semaphore so that + -- we do not check for ceiling violations. type Suspension_Object is limited private; -- Should be used for the implementation of Ada.Synchronous_Task_Control @@ -64,13 +64,8 @@ package System.Task_Primitives is -- Ada_Task_Control_Block. subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size; -- Import value from System.OS_Interface diff --git a/main/gcc/ada/s-taspri-solaris.ads b/main/gcc/ada/s-taspri-solaris.ads index 0c9c43267fc..6b2df7ff31f 100644 --- a/main/gcc/ada/s-taspri-solaris.ads +++ b/main/gcc/ada/s-taspri-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -70,13 +70,8 @@ package System.Task_Primitives is -- Ada_Task_Control_Block. subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := 0; -- No alternate signal stack is used on this platform diff --git a/main/gcc/ada/s-taspri-vms.ads b/main/gcc/ada/s-taspri-vms.ads deleted file mode 100644 index 891dee28c9d..00000000000 --- a/main/gcc/ada/s-taspri-vms.ads +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2011, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - --- This package provides low-level support for most tasking features - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - -with Interfaces.C; - -with System.OS_Interface; -with System.Aux_DEC; - -package System.Task_Primitives is - pragma Preelaborate; - - type Lock is limited private; - -- Should be used for implementation of protected objects - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. The difference between Lock - -- and the RTS_Lock is that the later one serves only as a semaphore so - -- that do not check for ceiling violations. - - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task basis. - -- A component of this type is guaranteed to be included in the - -- Ada_Task_Control_Block. - - subtype Task_Address is System.Aux_DEC.Short_Address; - -- Task_Address is the short version of address defined in System.Aux_DEC. - -- To avoid dragging Aux_DEC into tasking packages a tasking specific - -- subtype is defined here. - - Task_Address_Size : constant := System.Aux_DEC.Short_Address_Size; - -- The size of Task_Address - - Alternate_Stack_Size : constant := 0; - -- No alternate signal stack is used on this platform - -private - - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Prio : Interfaces.C.int; - Prio_Save : Interfaces.C.int; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Interface.pthread_mutex_t; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until ondition is signaled - end record; - - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the - -- same value (thr_self value). We do not want to use lock on those - -- operations and the only thing we have to make sure is that they - -- are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - - L : aliased RTS_Lock; - -- Protection for all components is lock L - - AST_Pending : Boolean; - -- Used to detect delay and sleep timeouts - - end record; - -end System.Task_Primitives; diff --git a/main/gcc/ada/s-taspri-vxworks.ads b/main/gcc/ada/s-taspri-vxworks.ads index 9b67dd91c28..4e3eba5fc45 100644 --- a/main/gcc/ada/s-taspri-vxworks.ads +++ b/main/gcc/ada/s-taspri-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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- -- @@ -61,13 +61,8 @@ package System.Task_Primitives is -- Ada_Task_Control_Block. subtype Task_Address is System.Address; - -- In some versions of Task_Primitives, notably for VMS, Task_Address is - -- the short version of address defined in System.Aux_DEC. To avoid - -- dragging Aux_DEC into tasking packages a tasking specific subtype is - -- defined here. - Task_Address_Size : constant := Standard'Address_Size; - -- The size of Task_Address + -- Type used for task addresses and its size Alternate_Stack_Size : constant := 0; -- No alternate signal stack is used on this platform diff --git a/main/gcc/ada/s-tassta.adb b/main/gcc/ada/s-tassta.adb index decfcab0f83..da76c6559e5 100644 --- a/main/gcc/ada/s-tassta.adb +++ b/main/gcc/ada/s-tassta.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -537,8 +537,6 @@ package body System.Tasking.Stages is if CPU /= Unspecified_CPU and then (CPU < Integer (System.Multiprocessors.CPU_Range'First) or else - CPU > Integer (System.Multiprocessors.CPU_Range'Last) - or else CPU > Integer (System.Multiprocessors.Number_Of_CPUs)) then raise Tasking_Error with "CPU not in range"; @@ -547,8 +545,8 @@ package body System.Tasking.Stages is else -- When the application code says nothing about the task affinity - -- (task without CPU aspect) then the compiler inserts the - -- Unspecified_CPU value which indicates to the run-time library that + -- (task without CPU aspect) then the compiler inserts the value + -- Unspecified_CPU which indicates to the run-time library that -- the task will activate and execute on the same processor as its -- activating task if the activating task is assigned a processor -- (RM D.16(14/3)). @@ -559,14 +557,20 @@ package body System.Tasking.Stages is else System.Multiprocessors.CPU_Range (CPU)); end if; - -- Find parent P of new Task, via master level number + -- Find parent P of new Task, via master level number. Independent + -- tasks should have Parent = Environment_Task, and all tasks created + -- by independent tasks are also independent. See, for example, + -- s-interr.adb, where Interrupt_Manager does "new Server_Task". The + -- access type is at library level, so the parent of the Server_Task + -- is Environment_Task. P := Self_ID; - if P /= null then - while P.Master_of_Task >= Master loop + if P.Master_of_Task <= Independent_Task_Level then + P := Environment_Task; + else + while P /= null and then P.Master_of_Task >= Master loop P := P.Common.Parent; - exit when P = null; end loop; end if; @@ -709,7 +713,6 @@ package body System.Tasking.Stages is SSL.Create_TSD (T.Common.Compiler_Data); T.Common.Activation_Link := Chain.T_ID; Chain.T_ID := T; - Initialization.Initialize_Attributes_Link.all (T); Created_Task := T; Initialization.Undefer_Abort_Nestable (Self_ID); @@ -816,7 +819,6 @@ package body System.Tasking.Stages is Ignore_1 : Boolean; Ignore_2 : Boolean; - pragma Unreferenced (Ignore_1, Ignore_2); function State (Int : System.Interrupt_Management.Interrupt_ID) return Character; @@ -956,7 +958,7 @@ package body System.Tasking.Stages is Initialization.Task_Lock (Self_Id); Lock_RTS; - Initialization.Finalize_Attributes_Link.all (T); + Initialization.Finalize_Attributes (T); Initialization.Remove_From_All_Tasks_List (T); Unlock_RTS; @@ -1050,7 +1052,10 @@ package body System.Tasking.Stages is SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100; Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size); - -- Actual area allocated for secondary stack + 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 + -- allocated here. Secondary_Stack_Address : System.Address := Secondary_Stack'Address; -- Address of secondary stack. In the fixed secondary stack case, this @@ -1117,6 +1122,9 @@ package body System.Tasking.Stages is begin pragma Assert (Self_ID.Deferral_Level = 1); + Debug.Master_Hook + (Self_ID, Self_ID.Common.Parent, Self_ID.Master_of_Task); + -- Assume a size of the stack taken at this stage if not Parameters.Sec_Stack_Dynamic then @@ -1522,12 +1530,6 @@ package body System.Tasking.Stages is Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); - function Tailored_Exception_Information - (E : Exception_Occurrence) return String; - pragma Import - (Ada, Tailored_Exception_Information, - "__gnat_tailored_exception_information"); - Excep : constant Exception_Occurrence_Access := SSL.Get_Current_Excep.all; @@ -1551,7 +1553,7 @@ package body System.Tasking.Stages is To_Stderr (System.Address_Image (To_Address (Self_Id))); To_Stderr (" terminated by unhandled exception"); To_Stderr ((1 => ASCII.LF)); - To_Stderr (Tailored_Exception_Information (Excep.all)); + To_Stderr (Exception_Information (Excep.all)); Initialization.Task_Unlock (Self_Id); end Trace_Unhandled_Exception_In_Task; @@ -1989,6 +1991,8 @@ package body System.Tasking.Stages is -- since the value is only updated by each task for itself. Self_ID.Master_Within := CM - 1; + + Debug.Master_Completed_Hook (Self_ID, CM); end Vulnerable_Complete_Master; ------------------------------ @@ -2079,7 +2083,7 @@ package body System.Tasking.Stages is end if; Write_Lock (T); - Initialization.Finalize_Attributes_Link.all (T); + Initialization.Finalize_Attributes (T); Unlock (T); if Single_Lock then diff --git a/main/gcc/ada/s-tasuti.adb b/main/gcc/ada/s-tasuti.adb index a6b362ee2aa..1a6444838a7 100644 --- a/main/gcc/ada/s-tasuti.adb +++ b/main/gcc/ada/s-tasuti.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -242,12 +242,10 @@ package body System.Tasking.Utilities is -- Make_Independent -- ---------------------- - procedure Make_Independent is + function Make_Independent return Boolean is Self_Id : constant Task_Id := STPO.Self; Environment_Task : constant Task_Id := STPO.Environment_Task; Parent : constant Task_Id := Self_Id.Common.Parent; - Parent_Needs_Updating : Boolean := False; - Master_of_Task : Integer; begin if Self_Id.Known_Tasks_Index /= -1 then @@ -263,23 +261,12 @@ package body System.Tasking.Utilities is Write_Lock (Environment_Task); Write_Lock (Self_Id); - pragma Assert (Parent = Environment_Task - or else Self_Id.Master_of_Task = Library_Task_Level); - - Master_of_Task := Self_Id.Master_of_Task; - Self_Id.Master_of_Task := Independent_Task_Level; - -- The run time assumes that the parent of an independent task is the -- environment task. - if Parent /= Environment_Task then + pragma Assert (Parent = Environment_Task); - -- We cannot lock three tasks at the same time, so defer the - -- operations on the parent. - - Parent_Needs_Updating := True; - Self_Id.Common.Parent := Environment_Task; - end if; + Self_Id.Master_of_Task := Independent_Task_Level; -- Update Independent_Task_Count that is needed for the GLADE -- termination rule. See also pending update in @@ -287,32 +274,12 @@ package body System.Tasking.Utilities is Independent_Task_Count := Independent_Task_Count + 1; - Unlock (Self_Id); - - -- Changing the parent after creation is not trivial. Do not forget - -- to update the old parent counts, and the new parent (i.e. the - -- Environment_Task) counts. - - if Parent_Needs_Updating then - Write_Lock (Parent); - Parent.Awake_Count := Parent.Awake_Count - 1; - Parent.Alive_Count := Parent.Alive_Count - 1; - Environment_Task.Awake_Count := Environment_Task.Awake_Count + 1; - Environment_Task.Alive_Count := Environment_Task.Alive_Count + 1; - Unlock (Parent); - end if; - - -- In case the environment task is already waiting for children to - -- complete. - -- ??? There may be a race condition if the environment task was not in - -- master completion sleep when this task was created, but now is + -- This should be called before the task reaches its "begin" (see spec), + -- which ensures that the environment task cannot race ahead and be + -- already waiting for children to complete. - if Environment_Task.Common.State = Master_Completion_Sleep and then - Master_of_Task = Environment_Task.Master_Within - then - Environment_Task.Common.Wait_Count := - Environment_Task.Common.Wait_Count - 1; - end if; + Unlock (Self_Id); + pragma Assert (Environment_Task.Common.State /= Master_Completion_Sleep); Unlock (Environment_Task); @@ -321,6 +288,11 @@ package body System.Tasking.Utilities is end if; Initialization.Undefer_Abort (Self_Id); + + -- Return True. Actually the return value is junk, since we expect it + -- always to be ignored (see spec), but we have to return something! + + return True; end Make_Independent; ------------------ @@ -505,13 +477,10 @@ package body System.Tasking.Utilities is (Self_ID, "Make_Passive: Phase 1, parent waiting", 'M')); -- If parent is in Master_Completion_Sleep, it cannot be on a - -- terminate alternative, hence it cannot have Wait_Count of - -- zero. ???Except that the race condition in Make_Independent can - -- cause Wait_Count to be zero, so we need to check for that. + -- terminate alternative, hence it cannot have Wait_Count of zero. - if P.Common.Wait_Count > 0 then - P.Common.Wait_Count := P.Common.Wait_Count - 1; - end if; + pragma Assert (P.Common.Wait_Count > 0); + P.Common.Wait_Count := P.Common.Wait_Count - 1; if P.Common.Wait_Count = 0 then Wakeup (P, Master_Completion_Sleep); @@ -519,8 +488,7 @@ package body System.Tasking.Utilities is else pragma Debug - (Debug.Trace - (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); + (Debug.Trace (Self_ID, "Make_Passive: Phase 1, parent awake", 'M')); null; end if; diff --git a/main/gcc/ada/s-tasuti.ads b/main/gcc/ada/s-tasuti.ads index 7f9e8bff20c..875489297ea 100644 --- a/main/gcc/ada/s-tasuti.ads +++ b/main/gcc/ada/s-tasuti.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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- -- @@ -44,7 +44,7 @@ package System.Tasking.Utilities is -- Task_Stage Related routines -- --------------------------------- - procedure Make_Independent; + function Make_Independent return Boolean; -- Move the current task to the outermost level (level 2) of the master -- hierarchy of the environment task. That is one level further out -- than normal tasks defined in library-level packages (level 3). The @@ -63,9 +63,34 @@ package System.Tasking.Utilities is -- will change the task's parent. This assumption is particularly -- important for master level completion and for the computation of -- Independent_Task_Count. + -- + -- NOTE WELL: Make_Independent should be called before the task reaches its + -- "begin", like this: + -- + -- task body Some_Independent_Task is + -- ... + -- Ignore : constant Boolean := Make_Independent; + -- ... + -- begin + -- + -- The return value is meaningless; the only reason this is a function is + -- to get around the Ada limitation that makes a procedure call + -- syntactically illegal before the "begin". + -- + -- Calling it before "begin" ensures that the call completes before the + -- activating task can proceed. This is important for preventing race + -- conditions. For example, if the environment task reaches + -- Finalize_Global_Tasks before some task has finished Make_Independent, + -- the program can hang. + -- + -- Note also that if a package declares independent tasks, it should not + -- initialize its package-body data after "begin" of the package, because + -- that's where the tasks are activated. Initializing such data before the + -- task activation helps prevent the tasks from accessing uninitialized + -- data. Independent_Task_Count : Natural := 0; - -- Number of independent task. This counter is incremented each time + -- Number of independent tasks. This counter is incremented each time -- Make_Independent is called. Note that if a server task terminates, -- this counter will not be decremented. Since Make_Independent locks -- the environment task (because every independent task depends on it), diff --git a/main/gcc/ada/a-caldel-vms.adb b/main/gcc/ada/s-tataat.adb similarity index 51% rename from main/gcc/ada/a-caldel-vms.adb rename to main/gcc/ada/s-tataat.adb index 1cf6f00d974..3f002fa1bfa 100644 --- a/main/gcc/ada/a-caldel-vms.adb +++ b/main/gcc/ada/s-tataat.adb @@ -2,12 +2,11 @@ -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- A D A . C A L E N D A R . D E L A Y S -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- -- -- -- B o d y -- -- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, AdaCore -- +-- Copyright (C) 2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,76 +29,66 @@ -- -- ------------------------------------------------------------------------------ --- This is the Alpha/VMS version +with System.Parameters; use System.Parameters; +with System.Tasking.Initialization; use System.Tasking.Initialization; -with System.OS_Primitives; -with System.Soft_Links; +package body System.Tasking.Task_Attributes is -package body Ada.Calendar.Delays is + type Index_Info is record + Used : Boolean; + -- Used is True if a given index is used by an instantiation of + -- Ada.Task_Attributes, False otherwise. - package OSP renames System.OS_Primitives; - package TSL renames System.Soft_Links; + Require_Finalization : Boolean; + -- Require_Finalization is True if the attribute requires finalization + end record; - use type TSL.Timed_Delay_Call; + Index_Array : array (1 .. Max_Attribute_Count) of Index_Info := + (others => (False, False)); - ----------------------- - -- Local Subprograms -- - ----------------------- + -- 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 (or null for an access type). - procedure Timed_Delay_NT (Time : Duration; Mode : Integer); - -- Timed delay procedure used when no tasking is active - - --------------- - -- Delay_For -- - --------------- - - procedure Delay_For (D : Duration) is - begin - TSL.Timed_Delay.all - (Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative); - end Delay_For; - - ----------------- - -- Delay_Until -- - ----------------- - - procedure Delay_Until (T : Time) is + function Next_Index (Require_Finalization : Boolean) return Integer is + Self_Id : constant Task_Id := Self; begin - TSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar); - end Delay_Until; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - Safe_Ada_High : constant Time := Time_Of (2250, 1, 1, 0.0); - -- A value distant enough to emulate "end of time" but which does not - -- cause overflow. - - Safe_T : constant Time := - (if T > Safe_Ada_High then Safe_Ada_High else T); - + Task_Lock (Self_Id); + + for J in Index_Array'Range loop + if not Index_Array (J).Used then + Index_Array (J).Used := True; + Index_Array (J).Require_Finalization := Require_Finalization; + Task_Unlock (Self_Id); + return J; + end if; + end loop; + + Task_Unlock (Self_Id); + raise Storage_Error with "Out of task attributes"; + end Next_Index; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Index : Integer) is + Self_Id : constant Task_Id := Self; begin - return OSP.To_Duration (OSP.OS_Time (Safe_T), OSP.Absolute_Calendar); - end To_Duration; + pragma Assert (Index in Index_Array'Range); + Task_Lock (Self_Id); + Index_Array (Index).Used := False; + Task_Unlock (Self_Id); + end Finalize; - -------------------- - -- Timed_Delay_NT -- - -------------------- + -------------------------- + -- Require_Finalization -- + -------------------------- - procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is + function Require_Finalization (Index : Integer) return Boolean is begin - OSP.Timed_Delay (Time, Mode); - end Timed_Delay_NT; - -begin - -- Set up the Timed_Delay soft link to the non tasking version if it has - -- not been already set. If tasking is present, Timed_Delay has already set - -- this soft link, or this will be overridden during the elaboration of - -- System.Tasking.Initialization + pragma Assert (Index in Index_Array'Range); + return Index_Array (Index).Require_Finalization; + end Require_Finalization; - if TSL.Timed_Delay = null then - TSL.Timed_Delay := Timed_Delay_NT'Access; - end if; -end Ada.Calendar.Delays; +end System.Tasking.Task_Attributes; diff --git a/main/gcc/ada/s-osinte-vms.adb b/main/gcc/ada/s-tataat.ads similarity index 55% rename from main/gcc/ada/s-osinte-vms.adb rename to main/gcc/ada/s-tataat.ads index ae8fc38c984..2dd5f5e6787 100644 --- a/main/gcc/ada/s-osinte-vms.adb +++ b/main/gcc/ada/s-tataat.ads @@ -2,12 +2,11 @@ -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- --- S Y S T E M . O S _ I N T E R F A C E -- +-- S Y S T E M . T A S K I N G . T A S K _ A T T R I B U T E S -- -- -- --- B o d y -- +-- S p e c -- -- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, AdaCore -- +-- Copyright (C) 2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,30 +29,42 @@ -- -- ------------------------------------------------------------------------------ --- This is the OpenVMS version of this package +-- This package provides support for the body of Ada.Task_Attributes --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. +with Ada.Unchecked_Conversion; -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. +package System.Tasking.Task_Attributes is -with Interfaces.C; use Interfaces.C; + type Deallocator is access procedure (Ptr : Atomic_Address); -package body System.OS_Interface is + type Attribute_Record is record + Free : Deallocator; + end record; + -- The real type is declared in Ada.Task_Attributes body: Real_Attribute. + -- As long as the first field is the deallocator we are good. - ----------------- - -- sched_yield -- - ----------------- + type Attribute_Access is access all Attribute_Record; + pragma No_Strict_Aliasing (Attribute_Access); - function sched_yield return int is - procedure sched_yield_base; - pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); + function To_Attribute is new + Ada.Unchecked_Conversion (Atomic_Address, Attribute_Access); - begin - sched_yield_base; - return 0; - end sched_yield; + function Next_Index (Require_Finalization : Boolean) return Integer; + -- Return the next attribute index available. Require_Finalization is True + -- if the attribute requires finalization and in particular its deallocator + -- (Free field in Attribute_Record) should be called. Raise Storage_Error + -- if no index is available. -end System.OS_Interface; + function Require_Finalization (Index : Integer) return Boolean; + -- Return True if a given attribute index requires call to Free. This call + -- is not protected against concurrent access, should only be called during + -- finalization of the corresponding instantiation of Ada.Task_Attributes, + -- or during finalization of a task. + + procedure Finalize (Index : Integer); + -- Finalize given Index, possibly allowing future reuse + +private + pragma Inline (Finalize); + pragma Inline (Require_Finalization); +end System.Tasking.Task_Attributes; diff --git a/main/gcc/ada/s-tpopde-vms.adb b/main/gcc/ada/s-tpopde-vms.adb deleted file mode 100644 index 4f7cdad6123..00000000000 --- a/main/gcc/ada/s-tpopde-vms.adb +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2009, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is for OpenVMS/Alpha - -with System.OS_Interface; -with System.Parameters; -with System.Tasking; -with Ada.Unchecked_Conversion; -with System.Soft_Links; - -package body System.Task_Primitives.Operations.DEC is - - use System.OS_Interface; - use System.Parameters; - use System.Tasking; - use System.Aux_DEC; - use type Interfaces.C.int; - - package SSL renames System.Soft_Links; - - -- The FAB_RAB_Type specifies where the context field (the calling - -- task) is stored. Other fields defined for FAB_RAB arent' need and - -- so are ignored. - - type FAB_RAB_Type is record - CTX : Unsigned_Longword; - end record; - - for FAB_RAB_Type use record - CTX at 24 range 0 .. 31; - end record; - - for FAB_RAB_Type'Size use 224; - - type FAB_RAB_Access_Type is access all FAB_RAB_Type; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Unsigned_Longword is new - Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); - - function To_Task_Id is new - Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id); - - function To_FAB_RAB is new - Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type); - - --------------------------- - -- Interrupt_AST_Handler -- - --------------------------- - - procedure Interrupt_AST_Handler (ID : Address) is - Result : Interfaces.C.int; - AST_Self_ID : constant Task_Id := To_Task_Id (ID); - begin - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Interrupt_AST_Handler; - - --------------------- - -- RMS_AST_Handler -- - --------------------- - - procedure RMS_AST_Handler (ID : Address) is - AST_Self_ID : constant Task_Id := To_Task_Id (To_FAB_RAB (ID).CTX); - Result : Interfaces.C.int; - - begin - AST_Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end RMS_AST_Handler; - - ---------- - -- Self -- - ---------- - - function Self return Unsigned_Longword is - Self_ID : constant Task_Id := Self; - begin - Self_ID.Common.LL.AST_Pending := True; - return To_Unsigned_Longword (Self); - end Self; - - ------------------------- - -- Starlet_AST_Handler -- - ------------------------- - - procedure Starlet_AST_Handler (ID : Address) is - Result : Interfaces.C.int; - AST_Self_ID : constant Task_Id := To_Task_Id (ID); - begin - AST_Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Starlet_AST_Handler; - - ---------------- - -- Task_Synch -- - ---------------- - - procedure Task_Synch is - Synch_Self_ID : constant Task_Id := Self; - - begin - if Single_Lock then - Lock_RTS; - else - Write_Lock (Synch_Self_ID); - end if; - - SSL.Abort_Defer.all; - Synch_Self_ID.Common.State := AST_Server_Sleep; - - while Synch_Self_ID.Common.LL.AST_Pending loop - Sleep (Synch_Self_ID, AST_Server_Sleep); - end loop; - - Synch_Self_ID.Common.State := Runnable; - - if Single_Lock then - Unlock_RTS; - else - Unlock (Synch_Self_ID); - end if; - - SSL.Abort_Undefer.all; - end Task_Synch; - -end System.Task_Primitives.Operations.DEC; diff --git a/main/gcc/ada/s-tpopde-vms.ads b/main/gcc/ada/s-tpopde-vms.ads deleted file mode 100644 index e690f306e7a..00000000000 --- a/main/gcc/ada/s-tpopde-vms.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2011, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is for OpenVMS/Alpha. --- -with System.Aux_DEC; -package System.Task_Primitives.Operations.DEC is - - procedure Interrupt_AST_Handler (ID : Address); - pragma Convention (C, Interrupt_AST_Handler); - -- Handles the AST for Ada 95 Interrupts - - procedure RMS_AST_Handler (ID : Address); - -- Handles the AST for RMS_Asynch_Operations - - function Self return System.Aux_DEC.Unsigned_Longword; - -- Returns the task identification for the AST - - procedure Starlet_AST_Handler (ID : Address); - -- Handles the AST for Starlet Tasking_Services - - procedure Task_Synch; - -- Synchronizes the task after the system service completes - -end System.Task_Primitives.Operations.DEC; diff --git a/main/gcc/ada/s-tpopsp-vms.adb b/main/gcc/ada/s-tpopsp-vms.adb deleted file mode 100644 index 42503f6cd99..00000000000 --- a/main/gcc/ada/s-tpopsp-vms.adb +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a VMS version of this package where foreign threads are --- recognized. - -separate (System.Task_Primitives.Operations) -package body Specific is - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_Id) is - pragma Warnings (Off, Environment_Task); - Result : Interfaces.C.int; - - begin - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - end Initialize; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return pthread_getspecific (ATCB_Key) /= System.Null_Address; - end Is_Valid_Task; - - --------- - -- Set -- - --------- - - procedure Set (Self_Id : Task_Id) is - Result : Interfaces.C.int; - begin - Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); - pragma Assert (Result = 0); - end Set; - - ---------- - -- Self -- - ---------- - - -- To make Ada tasks and C threads interoperate better, we have added some - -- functionality to Self. Suppose a C main program (with threads) calls an - -- Ada procedure and the Ada procedure calls the tasking runtime system. - -- Eventually, a call will be made to self. Since the call is not coming - -- from an Ada task, there will be no corresponding ATCB. - - -- What we do in Self is to catch references that do not come from - -- recognized Ada tasks, and create an ATCB for the calling thread. - - -- The new ATCB will be "detached" from the normal Ada task master - -- hierarchy, much like the existing implicitly created signal-server - -- tasks. - - function Self return Task_Id is - Result : System.Address; - - begin - Result := pthread_getspecific (ATCB_Key); - - -- If the key value is Null then it is a non-Ada task - - if Result /= System.Null_Address then - return To_Task_Id (Result); - else - return Register_Foreign_Thread; - end if; - end Self; - -end Specific; diff --git a/main/gcc/ada/s-tporft.adb b/main/gcc/ada/s-tporft.adb index 1da22901997..32bb1f08db9 100644 --- a/main/gcc/ada/s-tporft.adb +++ b/main/gcc/ada/s-tporft.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, 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- -- @@ -94,15 +94,6 @@ begin System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data); - -- ??? - -- The following call is commented out to avoid dependence on the - -- System.Tasking.Initialization package. It seems that if we want - -- Ada.Task_Attributes to work correctly for C threads we will need to - -- raise the visibility of this soft link to System.Soft_Links. We are - -- putting that off until this new functionality is otherwise stable. - - -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T); - Enter_Task (Self_Id); return Self_Id; diff --git a/main/gcc/ada/s-traceb-hpux.adb b/main/gcc/ada/s-traceb-hpux.adb index 734f0f4b6f3..9987cb3fe64 100644 --- a/main/gcc/ada/s-traceb-hpux.adb +++ b/main/gcc/ada/s-traceb-hpux.adb @@ -7,7 +7,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -262,6 +262,16 @@ package body System.Traceback is -- but it is not usable when frames with dynamically allocated space are -- on the way. +-- procedure Call_Chain +-- (Traceback : System.Address; +-- Max_Len : Natural; +-- Len : out Natural; +-- Exclude_Min : System.Address := System.Null_Address; +-- Exclude_Max : System.Address := System.Null_Address; +-- Skip_Frames : Natural := 1); +-- -- Same as the exported version, but takes Traceback as an Address +-- ???See declaration in the spec for why this is temporarily commented out. + ------------------ -- C_Call_Chain -- ------------------ @@ -271,7 +281,6 @@ package body System.Traceback is Max_Len : Natural) return Natural is Val : Natural; - begin Call_Chain (Traceback, Max_Len, Val); return Val; @@ -598,4 +607,22 @@ package body System.Traceback is Len := J - 1; end Call_Chain; + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + end System.Traceback; diff --git a/main/gcc/ada/s-traceb-mastop.adb b/main/gcc/ada/s-traceb-mastop.adb index 4b5a1774e53..0ce7c50f933 100644 --- a/main/gcc/ada/s-traceb-mastop.adb +++ b/main/gcc/ada/s-traceb-mastop.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -37,6 +37,16 @@ package body System.Traceback is use System.Machine_State_Operations; +-- procedure Call_Chain +-- (Traceback : System.Address; +-- Max_Len : Natural; +-- Len : out Natural; +-- Exclude_Min : System.Address := System.Null_Address; +-- Exclude_Max : System.Address := System.Null_Address; +-- Skip_Frames : Natural := 1); +-- -- Same as the exported version, but takes Traceback as an Address +-- ???See declaration in the spec for why this is temporarily commented out. + ---------------- -- Call_Chain -- ---------------- @@ -93,6 +103,24 @@ package body System.Traceback is Free_Machine_State (M); end Call_Chain; + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + ------------------ -- C_Call_Chain -- ------------------ diff --git a/main/gcc/ada/s-traceb.adb b/main/gcc/ada/s-traceb.adb index b32e2a1b075..0a8726c6596 100644 --- a/main/gcc/ada/s-traceb.adb +++ b/main/gcc/ada/s-traceb.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,17 +38,25 @@ pragma Compiler_Unit_Warning; package body System.Traceback is +-- procedure Call_Chain +-- (Traceback : System.Address; +-- Max_Len : Natural; +-- Len : out Natural; +-- Exclude_Min : System.Address := System.Null_Address; +-- Exclude_Max : System.Address := System.Null_Address; +-- Skip_Frames : Natural := 1); +-- -- Same as the exported version, but takes Traceback as an Address +-- ???See declaration in the spec for why this is temporarily commented out. + ------------------ -- C_Call_Chain -- ------------------ function C_Call_Chain (Traceback : System.Address; - Max_Len : Natural) - return Natural + Max_Len : Natural) return Natural is Val : Natural; - begin Call_Chain (Traceback, Max_Len, Val); return Val; @@ -90,4 +98,22 @@ package body System.Traceback is Skip_Frames => Skip_Frames + 1); end Call_Chain; + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + end System.Traceback; diff --git a/main/gcc/ada/s-traceb.ads b/main/gcc/ada/s-traceb.ads index fc5cfb2a899..dbfea6a6f6f 100644 --- a/main/gcc/ada/s-traceb.ads +++ b/main/gcc/ada/s-traceb.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,8 @@ pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. +with System.Traceback_Entries; + package System.Traceback is ---------------- @@ -46,23 +48,22 @@ package System.Traceback is ---------------- procedure Call_Chain - (Traceback : System.Address; + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; Max_Len : Natural; Len : out Natural; Exclude_Min : System.Address := System.Null_Address; Exclude_Max : System.Address := System.Null_Address; Skip_Frames : Natural := 1); - -- Store up to Max_Len code locations in Traceback, corresponding to - -- the current call chain. + -- Store up to Max_Len code locations in Traceback, corresponding to the + -- current call chain. -- - -- Traceback is the address of an array of addresses where the - -- result will be stored. + -- Traceback is an array of addresses where the result will be stored. -- -- Max_Len is the length of the Traceback array. If the call chain is -- longer than this, then additional entries are discarded, and the -- traceback is missing some of the highest level entries. -- - -- Len is the returned number of addresses stored in the Traceback array + -- Len is the number of addresses returned in the Traceback array -- -- Exclude_Min/Exclude_Max, if non null, provide a range of addresses -- to ignore from the computation of the traceback. @@ -77,10 +78,22 @@ package System.Traceback is -- number of stored entries. The first entry is the most recent call, -- and the last entry is the highest level call. + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the previous version, but takes Traceback as an Address. The + -- previous version is preferred. ???This version should be removed from + -- this spec, and calls replaced with calls to the previous version. This + -- declaration can be moved to the bodies (s-traceb.adb, s-traceb-hpux.adb, + -- and s-traceb-mastop.adb), but it should not be visible to clients. + function C_Call_Chain (Traceback : System.Address; - Max_Len : Natural) - return Natural; + Max_Len : Natural) return Natural; pragma Export (C, C_Call_Chain, "system__traceback__c_call_chain"); -- Version that can be used directly from C diff --git a/main/gcc/ada/s-traces-default.adb b/main/gcc/ada/s-traces-default.adb index 03145a95b8b..e370efafd46 100644 --- a/main/gcc/ada/s-traces-default.adb +++ b/main/gcc/ada/s-traces-default.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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- -- diff --git a/main/gcc/ada/s-traces.adb b/main/gcc/ada/s-traces.adb index e7116f5d129..abf7e8da9a6 100644 --- a/main/gcc/ada/s-traces.adb +++ b/main/gcc/ada/s-traces.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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- -- diff --git a/main/gcc/ada/s-traent-vms.adb b/main/gcc/ada/s-traent-vms.adb deleted file mode 100644 index 9e130419bf8..00000000000 --- a/main/gcc/ada/s-traent-vms.adb +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Traceback_Entries is - - ------------ - -- PC_For -- - ------------ - - function PC_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry.PC; - end PC_For; - - ------------ - -- PV_For -- - ------------ - - function PV_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry.PV; - end PV_For; - - ------------------ - -- TB_Entry_For -- - ------------------ - - function TB_Entry_For (PC : System.Address) return Traceback_Entry is - begin - return (PC => PC, PV => System.Null_Address); - end TB_Entry_For; - -end System.Traceback_Entries; diff --git a/main/gcc/ada/s-traent-vms.ads b/main/gcc/ada/s-traent-vms.ads deleted file mode 100644 index 45db3c4d09f..00000000000 --- a/main/gcc/ada/s-traent-vms.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2009, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/OpenVMS version of this package - -package System.Traceback_Entries is - pragma Preelaborate; - - -- Symbolization is performed by a VMS service which requires more - -- than an instruction pointer. - - type Traceback_Entry is record - PC : System.Address; -- Program Counter - PV : System.Address; -- Procedure Value - end record; - - pragma Suppress_Initialization (Traceback_Entry); - - Null_TB_Entry : constant Traceback_Entry := - (PC => System.Null_Address, - PV => System.Null_Address); - - function PC_For (TB_Entry : Traceback_Entry) return System.Address; - function PV_For (TB_Entry : Traceback_Entry) return System.Address; - - function TB_Entry_For (PC : System.Address) return Traceback_Entry; - -end System.Traceback_Entries; diff --git a/main/gcc/ada/s-traent.adb b/main/gcc/ada/s-traent.adb index cedb93280d6..48abe8a1193 100644 --- a/main/gcc/ada/s-traent.adb +++ b/main/gcc/ada/s-traent.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 @@ -- -- ------------------------------------------------------------------------------ +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions. + pragma Compiler_Unit_Warning; package body System.Traceback_Entries is diff --git a/main/gcc/ada/s-traent.ads b/main/gcc/ada/s-traent.ads index 1dbb9ec15d6..4d834261d8b 100644 --- a/main/gcc/ada/s-traent.ads +++ b/main/gcc/ada/s-traent.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2014, 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,6 +38,10 @@ -- version of the package, an entry is a mere code location representing the -- address of a call instruction part of the call-chain. +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions. + pragma Compiler_Unit_Warning; package System.Traceback_Entries is @@ -49,6 +53,8 @@ package System.Traceback_Entries is Null_TB_Entry : constant Traceback_Entry := System.Null_Address; -- This is the value to be used when initializing an entry + type Tracebacks_Array is array (Positive range <>) of Traceback_Entry; + function PC_For (TB_Entry : Traceback_Entry) return System.Address; pragma Inline (PC_For); -- Returns the address of the call instruction associated with the diff --git a/main/gcc/ada/g-trasym.adb b/main/gcc/ada/s-trasym.adb similarity index 87% copy from main/gcc/ada/g-trasym.adb copy to main/gcc/ada/s-trasym.adb index a825f80b704..ad5588761d1 100644 --- a/main/gcc/ada/g-trasym.adb +++ b/main/gcc/ada/s-trasym.adb @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T . T R A C E B A C K . S Y M B O L I C -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2012, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -36,13 +36,15 @@ with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; with System.Address_Image; -package body GNAT.Traceback.Symbolic is +package body System.Traceback.Symbolic is ------------------------ -- Symbolic_Traceback -- ------------------------ - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String + is begin if Traceback'Length = 0 then return ""; @@ -69,9 +71,11 @@ package body GNAT.Traceback.Symbolic is end if; end Symbolic_Traceback; - function Symbolic_Traceback (E : Exception_Occurrence) return String is + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence) return String + is begin - return Symbolic_Traceback (Tracebacks (E)); + return Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E)); end Symbolic_Traceback; -end GNAT.Traceback.Symbolic; +end System.Traceback.Symbolic; diff --git a/main/gcc/ada/g-trasym.ads b/main/gcc/ada/s-trasym.ads similarity index 75% copy from main/gcc/ada/g-trasym.ads copy to main/gcc/ada/s-trasym.ads index 62bb632c815..ea0b46bf9fc 100644 --- a/main/gcc/ada/g-trasym.ads +++ b/main/gcc/ada/s-trasym.ads @@ -2,11 +2,11 @@ -- -- -- GNAT RUN-TIME COMPONENTS -- -- -- --- G N A T . T R A C E B A C K . S Y M B O L I C -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2012, AdaCore -- +-- Copyright (C) 1999-2014, 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- -- @@ -31,19 +31,6 @@ -- Run-time symbolic traceback support --- The full capability is currently supported on the following targets: - --- HP-UX ia64 --- GNU/Linux x86, x86_64, ia64 --- FreeBSD x86, x86_64 --- Solaris sparc and x86 --- OpenVMS Alpha and ia64 --- Windows - --- Note: on targets other than those listed above, a dummy implementation of --- the body returns a series of LF separated strings of the form "0x..." --- corresponding to the addresses. - -- The routines provided in this package assume that your application has -- been compiled with debugging information turned on, since this information -- is used to build a symbolic traceback. @@ -71,30 +58,24 @@ -- OS facilities, and load them in memory, causing a significant cpu and -- memory overhead. --- Symbolic traceback from shared libraries is only supported for VMS, Windows --- and GNU/Linux. On other targets symbolic tracebacks are only supported for --- the main executable. You should consider using gdb to obtain symbolic --- traceback in such cases. - --- On VMS, there is no restriction on using this facility with shared --- libraries. However, the OS should be at least v7.3-1 and OS patch --- VMS731_TRACE-V0100 must be applied in order to use this package. - -- On platforms where the full capability is not supported, function -- Symbolic_Traceback return a list of addresses expressed as "0x..." -- separated by line feed. -with Ada.Exceptions; use Ada.Exceptions; +with Ada.Exceptions; -package GNAT.Traceback.Symbolic is +package System.Traceback.Symbolic is pragma Elaborate_Body; - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String; + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String; -- Build a string containing a symbolic traceback of the given call chain. -- Note: This procedure may be installed by Set_Trace_Decorator, to get a - -- symbolic traceback on all exceptions raised (see GNAT.Exception_Traces). + -- symbolic traceback on all exceptions raised (see + -- System.Exception_Traces). - function Symbolic_Traceback (E : Exception_Occurrence) return String; + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence) return String; -- Build string containing symbolic traceback of given exception occurrence -end GNAT.Traceback.Symbolic; +end System.Traceback.Symbolic; diff --git a/main/gcc/ada/s-tratas-default.adb b/main/gcc/ada/s-tratas-default.adb index 0c80fe96d05..24f0d248182 100644 --- a/main/gcc/ada/s-tratas-default.adb +++ b/main/gcc/ada/s-tratas-default.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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- -- diff --git a/main/gcc/ada/s-tratas.adb b/main/gcc/ada/s-tratas.adb index a65f70b9490..7a6ac5d8fe8 100644 --- a/main/gcc/ada/s-tratas.adb +++ b/main/gcc/ada/s-tratas.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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- -- diff --git a/main/gcc/ada/s-tratas.ads b/main/gcc/ada/s-tratas.ads index 7cb567a1ebd..8f89445cdc7 100644 --- a/main/gcc/ada/s-tratas.ads +++ b/main/gcc/ada/s-tratas.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2001-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, 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- -- diff --git a/main/gcc/ada/s-unstyp.ads b/main/gcc/ada/s-unstyp.ads index 3b97599be87..9eefc15b59c 100644 --- a/main/gcc/ada/s-unstyp.ads +++ b/main/gcc/ada/s-unstyp.ads @@ -50,10 +50,13 @@ package System.Unsigned_Types is -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) type Packed_Byte is mod 2 ** 8; + pragma Universal_Aliasing (Packed_Byte); for Packed_Byte'Size use 8; - -- Component type for Packed_Bytes array + -- Component type for Packed_Bytes1, Packed_Bytes2 and Packed_Byte4 arrays. + -- As this type is used by the compiler to implement operations on user + -- packed array, it needs to be able to alias any type. - type Packed_Bytes1 is array (Natural range <>) of Packed_Byte; + 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; -- This is the type used to implement packed arrays where no alignment diff --git a/main/gcc/ada/s-vaflop-vms-alpha.adb b/main/gcc/ada/s-vaflop-vms-alpha.adb deleted file mode 100644 index 51571720b67..00000000000 --- a/main/gcc/ada/s-vaflop-vms-alpha.adb +++ /dev/null @@ -1,695 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- --- (Version for Alpha OpenVMS) -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.IO; -with System.Machine_Code; use System.Machine_Code; - -package body System.Vax_Float_Operations is - - -- Declare the functions that do the conversions between floating-point - -- formats. Call the operands IEEE float so they get passed in - -- FP registers. - - function Cvt_G_T (X : T) return T; - function Cvt_T_G (X : T) return T; - function Cvt_T_F (X : T) return S; - - pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T"); - pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G"); - pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F"); - - -- In each of the conversion routines that are done with OTS calls, - -- we define variables of the corresponding IEEE type so that they are - -- passed and kept in the proper register class. - - Debug_String_Buffer : String (1 .. 32); - -- Buffer used by all Debug_String_x routines for returning result - - ------------ - -- D_To_G -- - ------------ - - function D_To_G (X : D) return G is - A, B : T; - C : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X)); - Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end D_To_G; - - ------------ - -- F_To_G -- - ------------ - - function F_To_G (X : F) return G is - A : T; - B : G; - begin - Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end F_To_G; - - ------------ - -- F_To_S -- - ------------ - - function F_To_S (X : F) return S is - A : T; - B : S; - - begin - -- Because converting to a wider FP format is a no-op, we say - -- A is 64-bit even though we are loading 32 bits into it. - - Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - - B := S (Cvt_G_T (A)); - return B; - end F_To_S; - - ------------ - -- G_To_D -- - ------------ - - function G_To_D (X : G) return D is - A, B : T; - C : D; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end G_To_D; - - ------------ - -- G_To_F -- - ------------ - - function G_To_F (X : G) return F is - A : T; - B : S; - C : F; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end G_To_F; - - ------------ - -- G_To_Q -- - ------------ - - function G_To_Q (X : G) return Q is - A : T; - B : Q; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - return B; - end G_To_Q; - - ------------ - -- G_To_T -- - ------------ - - function G_To_T (X : G) return T is - A, B : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - B := Cvt_G_T (A); - return B; - end G_To_T; - - ------------ - -- F_To_Q -- - ------------ - - function F_To_Q (X : F) return Q is - begin - return G_To_Q (F_To_G (X)); - end F_To_Q; - - ------------ - -- Q_To_F -- - ------------ - - function Q_To_F (X : Q) return F is - A : S; - B : F; - begin - Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); - Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); - return B; - end Q_To_F; - - ------------ - -- Q_To_G -- - ------------ - - function Q_To_G (X : Q) return G is - A : T; - B : G; - begin - Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end Q_To_G; - - ------------ - -- S_To_F -- - ------------ - - function S_To_F (X : S) return F is - A : S; - B : F; - begin - A := Cvt_T_F (T (X)); - Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); - return B; - end S_To_F; - - ------------ - -- T_To_G -- - ------------ - - function T_To_G (X : T) return G is - A : T; - B : G; - begin - A := Cvt_T_G (X); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end T_To_G; - - ------------ - -- T_To_D -- - ------------ - - function T_To_D (X : T) return D is - begin - return G_To_D (T_To_G (X)); - end T_To_D; - - ----------- - -- Abs_F -- - ----------- - - function Abs_F (X : F) return F is - A, B : S; - C : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end Abs_F; - - ----------- - -- Abs_G -- - ----------- - - function Abs_G (X : G) return G is - A, B : T; - C : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end Abs_G; - - ----------- - -- Add_F -- - ----------- - - function Add_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Add_F; - - ----------- - -- Add_G -- - ----------- - - function Add_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Add_G; - - -------------------- - -- Debug_Output_D -- - -------------------- - - procedure Debug_Output_D (Arg : D) is - begin - System.IO.Put (D'Image (Arg)); - end Debug_Output_D; - - -------------------- - -- Debug_Output_F -- - -------------------- - - procedure Debug_Output_F (Arg : F) is - begin - System.IO.Put (F'Image (Arg)); - end Debug_Output_F; - - -------------------- - -- Debug_Output_G -- - -------------------- - - procedure Debug_Output_G (Arg : G) is - begin - System.IO.Put (G'Image (Arg)); - end Debug_Output_G; - - -------------------- - -- Debug_String_D -- - -------------------- - - function Debug_String_D (Arg : D) return System.Address is - Image_String : constant String := D'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_D; - - -------------------- - -- Debug_String_F -- - -------------------- - - function Debug_String_F (Arg : F) return System.Address is - Image_String : constant String := F'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_F; - - -------------------- - -- Debug_String_G -- - -------------------- - - function Debug_String_G (Arg : G) return System.Address is - Image_String : constant String := G'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_G; - - ----------- - -- Div_F -- - ----------- - - function Div_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Div_F; - - ----------- - -- Div_G -- - ----------- - - function Div_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Div_G; - - ---------- - -- Eq_F -- - ---------- - - function Eq_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Eq_F; - - ---------- - -- Eq_G -- - ---------- - - function Eq_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Eq_G; - - ---------- - -- Le_F -- - ---------- - - function Le_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Le_F; - - ---------- - -- Le_G -- - ---------- - - function Le_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Le_G; - - ---------- - -- Lt_F -- - ---------- - - function Lt_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Lt_F; - - ---------- - -- Lt_G -- - ---------- - - function Lt_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Lt_G; - - ----------- - -- Mul_F -- - ----------- - - function Mul_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Mul_F; - - ----------- - -- Mul_G -- - ----------- - - function Mul_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Mul_G; - - ---------- - -- Ne_F -- - ---------- - - function Ne_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R = 0.0; - end Ne_F; - - ---------- - -- Ne_G -- - ---------- - - function Ne_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R = 0.0; - end Ne_G; - - ----------- - -- Neg_F -- - ----------- - - function Neg_F (X : F) return F is - A, B : S; - C : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("subf $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end Neg_F; - - ----------- - -- Neg_G -- - ----------- - - function Neg_G (X : G) return G is - A, B : T; - C : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("subg $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end Neg_G; - - -------- - -- pd -- - -------- - - procedure pd (Arg : D) is - begin - System.IO.Put_Line (D'Image (Arg)); - end pd; - - -------- - -- pf -- - -------- - - procedure pf (Arg : F) is - begin - System.IO.Put_Line (F'Image (Arg)); - end pf; - - -------- - -- pg -- - -------- - - procedure pg (Arg : G) is - begin - System.IO.Put_Line (G'Image (Arg)); - end pg; - - -------------- - -- Return_D -- - -------------- - - function Return_D (X : D) return D is - R : D; - begin - -- The return value is already in $f0 so we need to trick the compiler - -- into thinking that we're moving X to $f0. - Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", - Volatile => True); - Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); - return R; - end Return_D; - - -------------- - -- Return_F -- - -------------- - - function Return_F (X : F) return F is - R : F; - begin - -- The return value is already in $f0 so we need to trick the compiler - -- into thinking that we're moving X to $f0. - Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), - Clobber => "$f0", Volatile => True); - return R; - end Return_F; - - -------------- - -- Return_G -- - -------------- - - function Return_G (X : G) return G is - R : G; - begin - -- The return value is already in $f0 so we need to trick the compiler - -- into thinking that we're moving X to $f0. - Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), - Clobber => "$f0", Volatile => True); - return R; - end Return_G; - - ----------- - -- Sub_F -- - ----------- - - function Sub_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Sub_F; - - ----------- - -- Sub_G -- - ----------- - - function Sub_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Sub_G; - - ------------- - -- Valid_D -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_D (Arg : D) return Boolean is - Val : constant T := G_To_T (D_To_G (Arg)); - begin - return Val'Valid; - end Valid_D; - - ------------- - -- Valid_F -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_F (Arg : F) return Boolean is - Val : constant S := F_To_S (Arg); - begin - return Val'Valid; - end Valid_F; - - ------------- - -- Valid_G -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_G (Arg : G) return Boolean is - Val : constant T := G_To_T (Arg); - begin - return Val'Valid; - end Valid_G; - -end System.Vax_Float_Operations; diff --git a/main/gcc/ada/s-vaflop.adb b/main/gcc/ada/s-vaflop.adb deleted file mode 100644 index ac50817c8d7..00000000000 --- a/main/gcc/ada/s-vaflop.adb +++ /dev/null @@ -1,503 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a dummy body for use on non-Alpha systems so that the library --- can compile. This dummy version uses ordinary conversions and other --- arithmetic operations. It is used only for testing purposes in the --- case where the -gnatdm switch is used to force testing of VMS features --- on non-VMS systems. - -with System.IO; - -package body System.Vax_Float_Operations is - pragma Warnings (Off); - -- Warnings about infinite recursion when the -gnatdm switch is used - - ----------- - -- Abs_F -- - ----------- - - function Abs_F (X : F) return F is - begin - return abs X; - end Abs_F; - - ----------- - -- Abs_G -- - ----------- - - function Abs_G (X : G) return G is - begin - return abs X; - end Abs_G; - - ----------- - -- Add_F -- - ----------- - - function Add_F (X, Y : F) return F is - begin - return X + Y; - end Add_F; - - ----------- - -- Add_G -- - ----------- - - function Add_G (X, Y : G) return G is - begin - return X + Y; - end Add_G; - - ------------ - -- D_To_G -- - ------------ - - function D_To_G (X : D) return G is - begin - return G (X); - end D_To_G; - - -------------------- - -- Debug_Output_D -- - -------------------- - - procedure Debug_Output_D (Arg : D) is - begin - System.IO.Put (D'Image (Arg)); - end Debug_Output_D; - - -------------------- - -- Debug_Output_F -- - -------------------- - - procedure Debug_Output_F (Arg : F) is - begin - System.IO.Put (F'Image (Arg)); - end Debug_Output_F; - - -------------------- - -- Debug_Output_G -- - -------------------- - - procedure Debug_Output_G (Arg : G) is - begin - System.IO.Put (G'Image (Arg)); - end Debug_Output_G; - - -------------------- - -- Debug_String_D -- - -------------------- - - Debug_String_Buffer : String (1 .. 32); - -- Buffer used by all Debug_String_x routines for returning result - - function Debug_String_D (Arg : D) return System.Address is - Image_String : constant String := D'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_D; - - -------------------- - -- Debug_String_F -- - -------------------- - - function Debug_String_F (Arg : F) return System.Address is - Image_String : constant String := F'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_F; - - -------------------- - -- Debug_String_G -- - -------------------- - - function Debug_String_G (Arg : G) return System.Address is - Image_String : constant String := G'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_G; - - ----------- - -- Div_F -- - ----------- - - function Div_F (X, Y : F) return F is - begin - return X / Y; - end Div_F; - - ----------- - -- Div_G -- - ----------- - - function Div_G (X, Y : G) return G is - begin - return X / Y; - end Div_G; - - ---------- - -- Eq_F -- - ---------- - - function Eq_F (X, Y : F) return Boolean is - begin - return X = Y; - end Eq_F; - - ---------- - -- Eq_G -- - ---------- - - function Eq_G (X, Y : G) return Boolean is - begin - return X = Y; - end Eq_G; - - ------------ - -- F_To_G -- - ------------ - - function F_To_G (X : F) return G is - begin - return G (X); - end F_To_G; - - ------------ - -- F_To_Q -- - ------------ - - function F_To_Q (X : F) return Q is - begin - return Q (X); - end F_To_Q; - - ------------ - -- F_To_S -- - ------------ - - function F_To_S (X : F) return S is - begin - return S (X); - end F_To_S; - - ------------ - -- G_To_D -- - ------------ - - function G_To_D (X : G) return D is - begin - return D (X); - end G_To_D; - - ------------ - -- G_To_F -- - ------------ - - function G_To_F (X : G) return F is - begin - return F (X); - end G_To_F; - - ------------ - -- G_To_Q -- - ------------ - - function G_To_Q (X : G) return Q is - begin - return Q (X); - end G_To_Q; - - ------------ - -- G_To_T -- - ------------ - - function G_To_T (X : G) return T is - begin - return T (X); - end G_To_T; - - ---------- - -- Le_F -- - ---------- - - function Le_F (X, Y : F) return Boolean is - begin - return X <= Y; - end Le_F; - - ---------- - -- Le_G -- - ---------- - - function Le_G (X, Y : G) return Boolean is - begin - return X <= Y; - end Le_G; - - ---------- - -- Lt_F -- - ---------- - - function Lt_F (X, Y : F) return Boolean is - begin - return X < Y; - end Lt_F; - - ---------- - -- Lt_G -- - ---------- - - function Lt_G (X, Y : G) return Boolean is - begin - return X < Y; - end Lt_G; - - ----------- - -- Mul_F -- - ----------- - - function Mul_F (X, Y : F) return F is - begin - return X * Y; - end Mul_F; - - ----------- - -- Mul_G -- - ----------- - - function Mul_G (X, Y : G) return G is - begin - return X * Y; - end Mul_G; - - ---------- - -- Ne_F -- - ---------- - - function Ne_F (X, Y : F) return Boolean is - begin - return X /= Y; - end Ne_F; - - ---------- - -- Ne_G -- - ---------- - - function Ne_G (X, Y : G) return Boolean is - begin - return X /= Y; - end Ne_G; - - ----------- - -- Neg_F -- - ----------- - - function Neg_F (X : F) return F is - begin - return -X; - end Neg_F; - - ----------- - -- Neg_G -- - ----------- - - function Neg_G (X : G) return G is - begin - return -X; - end Neg_G; - - -------- - -- pd -- - -------- - - procedure pd (Arg : D) is - begin - System.IO.Put_Line (D'Image (Arg)); - end pd; - - -------- - -- pf -- - -------- - - procedure pf (Arg : F) is - begin - System.IO.Put_Line (F'Image (Arg)); - end pf; - - -------- - -- pg -- - -------- - - procedure pg (Arg : G) is - begin - System.IO.Put_Line (G'Image (Arg)); - end pg; - - ------------ - -- Q_To_F -- - ------------ - - function Q_To_F (X : Q) return F is - begin - return F (X); - end Q_To_F; - - ------------ - -- Q_To_G -- - ------------ - - function Q_To_G (X : Q) return G is - begin - return G (X); - end Q_To_G; - - ------------ - -- S_To_F -- - ------------ - - function S_To_F (X : S) return F is - begin - return F (X); - end S_To_F; - - -------------- - -- Return_D -- - -------------- - - function Return_D (X : D) return D is - begin - return X; - end Return_D; - - -------------- - -- Return_F -- - -------------- - - function Return_F (X : F) return F is - begin - return X; - end Return_F; - - -------------- - -- Return_G -- - -------------- - - function Return_G (X : G) return G is - begin - return X; - end Return_G; - - ----------- - -- Sub_F -- - ----------- - - function Sub_F (X, Y : F) return F is - begin - return X - Y; - end Sub_F; - - ----------- - -- Sub_G -- - ----------- - - function Sub_G (X, Y : G) return G is - begin - return X - Y; - end Sub_G; - - ------------ - -- T_To_D -- - ------------ - - function T_To_D (X : T) return D is - begin - return G_To_D (T_To_G (X)); - end T_To_D; - - ------------ - -- T_To_G -- - ------------ - - function T_To_G (X : T) return G is - begin - return G (X); - end T_To_G; - - ------------- - -- Valid_D -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_D (Arg : D) return Boolean is - Val : constant T := G_To_T (D_To_G (Arg)); - begin - return Val'Valid; - end Valid_D; - - ------------- - -- Valid_F -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_F (Arg : F) return Boolean is - Val : constant S := F_To_S (Arg); - begin - return Val'Valid; - end Valid_F; - - ------------- - -- Valid_G -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_G (Arg : G) return Boolean is - Val : constant T := G_To_T (Arg); - begin - return Val'Valid; - end Valid_G; - -end System.Vax_Float_Operations; diff --git a/main/gcc/ada/s-vaflop.ads b/main/gcc/ada/s-vaflop.ads deleted file mode 100644 index 49120b74eff..00000000000 --- a/main/gcc/ada/s-vaflop.ads +++ /dev/null @@ -1,247 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains runtime routines for handling the non-IEEE --- floating-point formats used on the Vax and the Alpha. - -package System.Vax_Float_Operations is - - pragma Warnings (Off); - -- Suppress warnings if not on Alpha/VAX - - type D is digits 9; - pragma Float_Representation (VAX_Float, D); - -- D Float type on Vax - - type G is digits 15; - pragma Float_Representation (VAX_Float, G); - -- G Float type on Vax - - type F is digits 6; - pragma Float_Representation (VAX_Float, F); - -- F Float type on Vax - - type S is digits 6; - pragma Float_Representation (IEEE_Float, S); - -- IEEE short - - type T is digits 15; - pragma Float_Representation (IEEE_Float, T); - -- IEEE long - - pragma Warnings (On); - - type Q is range -2 ** 63 .. +(2 ** 63 - 1); - -- 64-bit signed integer - - -------------------------- - -- Conversion Functions -- - -------------------------- - - function D_To_G (X : D) return G; - function G_To_D (X : G) return D; - -- Conversions between D float and G float - - function G_To_F (X : G) return F; - function F_To_G (X : F) return G; - -- Conversions between F float and G float - - function F_To_S (X : F) return S; - function S_To_F (X : S) return F; - -- Conversions between F float and IEEE short - - function G_To_T (X : G) return T; - function T_To_G (X : T) return G; - -- Conversions between G float and IEEE long - - function F_To_Q (X : F) return Q; - function Q_To_F (X : Q) return F; - -- Conversions between F float and 64-bit integer - - function G_To_Q (X : G) return Q; - function Q_To_G (X : Q) return G; - -- Conversions between G float and 64-bit integer - - function T_To_D (X : T) return D; - -- Conversion from IEEE long to D_Float (used for literals) - - -------------------------- - -- Arithmetic Functions -- - -------------------------- - - function Abs_F (X : F) return F; - function Abs_G (X : G) return G; - -- Absolute value of F/G float - - function Add_F (X, Y : F) return F; - function Add_G (X, Y : G) return G; - -- Addition of F/G float - - function Div_F (X, Y : F) return F; - function Div_G (X, Y : G) return G; - -- Division of F/G float - - function Mul_F (X, Y : F) return F; - function Mul_G (X, Y : G) return G; - -- Multiplication of F/G float - - function Neg_F (X : F) return F; - function Neg_G (X : G) return G; - -- Negation of F/G float - - function Sub_F (X, Y : F) return F; - function Sub_G (X, Y : G) return G; - -- Subtraction of F/G float - - -------------------------- - -- Comparison Functions -- - -------------------------- - - function Eq_F (X, Y : F) return Boolean; - function Eq_G (X, Y : G) return Boolean; - -- Compares for X = Y - - function Le_F (X, Y : F) return Boolean; - function Le_G (X, Y : G) return Boolean; - -- Compares for X <= Y - - function Lt_F (X, Y : F) return Boolean; - function Lt_G (X, Y : G) return Boolean; - -- Compares for X < Y - - function Ne_F (X, Y : F) return Boolean; - function Ne_G (X, Y : G) return Boolean; - -- Compares for X /= Y - - ---------------------- - -- Return Functions -- - ---------------------- - - function Return_D (X : D) return D; - function Return_F (X : F) return F; - function Return_G (X : G) return G; - -- Deal with returned value for an imported function where the function - -- result is of VAX Float type. Usually nothing needs to be done, and these - -- functions return their argument unchanged. But for the case of VMS Alpha - -- the return value is already in $f0, so we need to trick the compiler - -- into thinking that we are moving X to $f0. See bodies for this case - -- for the Asm sequence generated to achieve this. - - ---------------------------------- - -- Routines for Valid Attribute -- - ---------------------------------- - - function Valid_D (Arg : D) return Boolean; - function Valid_F (Arg : F) return Boolean; - function Valid_G (Arg : G) return Boolean; - -- Test whether Arg has a valid representation - - ---------------------- - -- Debug Procedures -- - ---------------------- - - procedure Debug_Output_D (Arg : D); - procedure Debug_Output_F (Arg : F); - procedure Debug_Output_G (Arg : G); - pragma Export (Ada, Debug_Output_D); - pragma Export (Ada, Debug_Output_F); - pragma Export (Ada, Debug_Output_G); - -- These routines output their argument in decimal string form, with - -- no terminating line return. They are provided for implicit use by - -- the pre gnat-3.12w GDB, and are retained for backwards compatibility. - - function Debug_String_D (Arg : D) return System.Address; - function Debug_String_F (Arg : F) return System.Address; - function Debug_String_G (Arg : G) return System.Address; - pragma Export (Ada, Debug_String_D); - pragma Export (Ada, Debug_String_F); - pragma Export (Ada, Debug_String_G); - -- These routines return a decimal C string image of their argument. - -- They are provided for implicit use by the debugger, in response to - -- the special encoding used for Vax floating-point types (see Exp_Dbug - -- for details). They supersede the above Debug_Output_D/F/G routines - -- which didn't work properly with GDBTK. - - procedure pd (Arg : D); - procedure pf (Arg : F); - procedure pg (Arg : G); - pragma Export (Ada, pd); - pragma Export (Ada, pf); - pragma Export (Ada, pg); - -- These are like the Debug_Output_D/F/G procedures except that they - -- output a line return after the output. They were originally present - -- for direct use in GDB before GDB recognized Vax floating-point - -- types, and are retained for backwards compatibility. - -private - pragma Inline_Always (D_To_G); - pragma Inline_Always (F_To_G); - pragma Inline_Always (F_To_Q); - pragma Inline_Always (F_To_S); - pragma Inline_Always (G_To_D); - pragma Inline_Always (G_To_F); - pragma Inline_Always (G_To_Q); - pragma Inline_Always (G_To_T); - pragma Inline_Always (Q_To_F); - pragma Inline_Always (Q_To_G); - pragma Inline_Always (S_To_F); - pragma Inline_Always (T_To_G); - - pragma Inline_Always (Abs_F); - pragma Inline_Always (Abs_G); - pragma Inline_Always (Add_F); - pragma Inline_Always (Add_G); - pragma Inline_Always (Div_G); - pragma Inline_Always (Div_F); - pragma Inline_Always (Mul_F); - pragma Inline_Always (Mul_G); - pragma Inline_Always (Neg_G); - pragma Inline_Always (Neg_F); - pragma Inline_Always (Return_D); - pragma Inline_Always (Return_F); - pragma Inline_Always (Return_G); - pragma Inline_Always (Sub_F); - pragma Inline_Always (Sub_G); - - pragma Inline_Always (Eq_F); - pragma Inline_Always (Eq_G); - pragma Inline_Always (Le_F); - pragma Inline_Always (Le_G); - pragma Inline_Always (Lt_F); - pragma Inline_Always (Lt_G); - pragma Inline_Always (Ne_F); - pragma Inline_Always (Ne_G); - - pragma Inline_Always (Valid_D); - pragma Inline_Always (Valid_F); - pragma Inline_Always (Valid_G); - -end System.Vax_Float_Operations; diff --git a/main/gcc/ada/s-vector.ads b/main/gcc/ada/s-vector.ads index 7205258ab04..4c529b2924b 100644 --- a/main/gcc/ada/s-vector.ads +++ b/main/gcc/ada/s-vector.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/s-vmexta.adb b/main/gcc/ada/s-vmexta.adb deleted file mode 100644 index 1164ff8994f..00000000000 --- a/main/gcc/ada/s-vmexta.adb +++ /dev/null @@ -1,187 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is an Alpha/VMS package - -with System.HTable; -pragma Elaborate_All (System.HTable); -with System.Storage_Elements; use System.Storage_Elements; - -package body System.VMS_Exception_Table is - - type HTable_Headers is range 1 .. 37; - - type Exception_Code_Data; - type Exception_Code_Data_Ptr is access all Exception_Code_Data; - - -- The following record maps an imported VMS condition to an - -- Ada exception. - - type Exception_Code_Data is record - Code : Exception_Code; - Except : SSL.Exception_Data_Ptr; - HTable_Ptr : Exception_Code_Data_Ptr; - end record; - - procedure Set_HT_Link - (T : Exception_Code_Data_Ptr; - Next : Exception_Code_Data_Ptr); - - function Get_HT_Link (T : Exception_Code_Data_Ptr) - return Exception_Code_Data_Ptr; - - function Hash (F : Exception_Code) return HTable_Headers; - function Get_Key (T : Exception_Code_Data_Ptr) return Exception_Code; - - package Exception_Code_HTable is new System.HTable.Static_HTable ( - Header_Num => HTable_Headers, - Element => Exception_Code_Data, - Elmt_Ptr => Exception_Code_Data_Ptr, - Null_Ptr => null, - Set_Next => Set_HT_Link, - Next => Get_HT_Link, - Key => Exception_Code, - Get_Key => Get_Key, - Hash => Hash, - Equal => "="); - - ------------------ - -- Base_Code_In -- - ------------------ - - function Base_Code_In - (Code : Exception_Code) return Exception_Code - is - begin - return To_Address (To_Integer (Code) and not 2#0111#); - end Base_Code_In; - - --------------------- - -- Coded_Exception -- - --------------------- - - function Coded_Exception - (X : Exception_Code) return SSL.Exception_Data_Ptr - is - Res : Exception_Code_Data_Ptr; - - begin - Res := Exception_Code_HTable.Get (X); - - if Res /= null then - return Res.Except; - else - return null; - end if; - - end Coded_Exception; - - ----------------- - -- Get_HT_Link -- - ----------------- - - function Get_HT_Link - (T : Exception_Code_Data_Ptr) return Exception_Code_Data_Ptr - is - begin - return T.HTable_Ptr; - end Get_HT_Link; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (T : Exception_Code_Data_Ptr) - return Exception_Code - is - begin - return T.Code; - end Get_Key; - - ---------- - -- Hash -- - ---------- - - function Hash - (F : Exception_Code) return HTable_Headers - is - Headers_Magnitude : constant Exception_Code := - Exception_Code (HTable_Headers'Last - HTable_Headers'First + 1); - - begin - return HTable_Headers - (To_Address ((To_Integer (F) mod To_Integer (Headers_Magnitude)) + 1)); - end Hash; - - ---------------------------- - -- Register_VMS_Exception -- - ---------------------------- - - procedure Register_VMS_Exception - (Code : Exception_Code; - E : SSL.Exception_Data_Ptr) - is - -- We bind the exception data with the base code found in the - -- input value, that is with the severity bits masked off. - - Excode : constant Exception_Code := Base_Code_In (Code); - - begin - -- The exception data registered here is mostly filled prior to this - -- call and by __gnat_error_handler when the exception is raised. We - -- still need to fill a couple of components for exceptions that will - -- be used as propagation filters (exception data pointer registered - -- as choices in the unwind tables): in some import/export cases, the - -- exception pointers for the choice and the propagated occurrence may - -- indeed be different for a single import code, and the personality - -- routine attempts to match the import codes in this case. - - E.Lang := 'V'; - E.Foreign_Data := Excode; - - if Exception_Code_HTable.Get (Excode) = null then - Exception_Code_HTable.Set (new Exception_Code_Data'(Excode, E, null)); - end if; - end Register_VMS_Exception; - - ----------------- - -- Set_HT_Link -- - ----------------- - - procedure Set_HT_Link - (T : Exception_Code_Data_Ptr; - Next : Exception_Code_Data_Ptr) - is - begin - T.HTable_Ptr := Next; - end Set_HT_Link; - -end System.VMS_Exception_Table; diff --git a/main/gcc/ada/s-vmexta.ads b/main/gcc/ada/s-vmexta.ads deleted file mode 100644 index 5ad3f3cd373..00000000000 --- a/main/gcc/ada/s-vmexta.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V M S _ E X C E P T I O N _ T A B L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is usually used only on OpenVMS systems in the case --- where there is at least one Import/Export exception present. - -with System.Standard_Library; - -package System.VMS_Exception_Table is - - package SSL renames System.Standard_Library; - - subtype Exception_Code is System.Address; - - procedure Register_VMS_Exception - (Code : Exception_Code; - E : SSL.Exception_Data_Ptr); - -- Register an exception in hash table mapping with a VMS condition code. - -- - -- The table is used by exception code (the personnality routine) to detect - -- wether a VMS exception (aka condition) is known by the Ada code. In - -- that case, the identity of the imported or exported exception is used - -- to create the occurrence. - - -- LOTS more comments needed here regarding the entire scheme ??? - -private - - -- The following functions are directly called (without import/export) in - -- init.c by __gnat_handle_vms_condition. - - function Base_Code_In (Code : Exception_Code) return Exception_Code; - -- Value of Code with the severity bits masked off - - function Coded_Exception (X : Exception_Code) - return SSL.Exception_Data_Ptr; - -- Given a VMS condition, find and return its allocated Ada exception - -end System.VMS_Exception_Table; diff --git a/main/gcc/ada/s-vxwork-x86.ads b/main/gcc/ada/s-vxwork-x86.ads index 566b71b5c53..fac24f316fd 100644 --- a/main/gcc/ada/s-vxwork-x86.ads +++ b/main/gcc/ada/s-vxwork-x86.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, 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- -- diff --git a/main/gcc/ada/s-wwdwch.ads b/main/gcc/ada/s-wwdwch.ads index af42232be74..ecdd93f5108 100644 --- a/main/gcc/ada/s-wwdwch.ads +++ b/main/gcc/ada/s-wwdwch.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/scans.ads b/main/gcc/ada/scans.ads index ae7f91d9e42..682bb6c72fd 100644 --- a/main/gcc/ada/scans.ads +++ b/main/gcc/ada/scans.ads @@ -472,6 +472,10 @@ package Scans is -- Is it really right for this to be a Name rather than a String, what -- about the case of Wide_Wide_Characters??? + Inside_Depends : Boolean := False; + -- Flag set True for parsing the argument of a Depends pragma or aspect + -- (used to allow/require non-standard style rules for =>+ with -gnatyt). + Inside_If_Expression : Nat := 0; -- This is a counter that is set non-zero while scanning out an if -- expression (incremented on entry, decremented on exit). It is used to diff --git a/main/gcc/ada/scng.adb b/main/gcc/ada/scng.adb index 8ccdda628a5..3e31e5af82d 100644 --- a/main/gcc/ada/scng.adb +++ b/main/gcc/ada/scng.adb @@ -1571,7 +1571,7 @@ package body Scng is Token := Tok_Arrow; if Style_Check then - Style.Check_Arrow; + Style.Check_Arrow (Inside_Depends); end if; return; diff --git a/main/gcc/ada/scos.h b/main/gcc/ada/scos.h index d997c9df83a..f7b4aba403c 100644 --- a/main/gcc/ada/scos.h +++ b/main/gcc/ada/scos.h @@ -37,7 +37,7 @@ typedef Int SCO_Unit_Index; struct SCO_Unit_Table_Entry { - Fat_Pointer File_Name; + String_Pointer File_Name; Int File_Index; Nat Dep_Num; Nat From, To; diff --git a/main/gcc/ada/sem.adb b/main/gcc/ada/sem.adb index b1368f4b732..f1dd3665731 100644 --- a/main/gcc/ada/sem.adb +++ b/main/gcc/ada/sem.adb @@ -1268,7 +1268,6 @@ package body Sem is Next => Suppress_Stack_Entries); Suppress_Stack_Entries := Global_Suppress_Stack_Top; return; - end Push_Global_Suppress_Stack_Entry; ------------------------------------- @@ -1310,6 +1309,7 @@ package body Sem is S_GNAT_Mode : constant Boolean := GNAT_Mode; S_Global_Dis_Names : constant Boolean := Global_Discard_Names; S_In_Assertion_Expr : constant Nat := In_Assertion_Expr; + S_In_Default_Expr : constant Boolean := In_Default_Expr; S_In_Spec_Expr : constant Boolean := In_Spec_Expression; S_Inside_A_Generic : constant Boolean := Inside_A_Generic; S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope; @@ -1411,16 +1411,39 @@ package body Sem is GNAT_Mode := True; end if; + -- For generic main, never do expansion + if Generic_Main then Expander_Mode_Save_And_Set (False); + + -- Non generic case + else Expander_Mode_Save_And_Set - (Operating_Mode = Generate_Code or Debug_Flag_X); + + -- Turn on expansion if generating code + + (Operating_Mode = Generate_Code + + -- or if special debug flag -gnatdx is set + + or else Debug_Flag_X + + -- Or if in configuration run-time mode. We do this so we get + -- error messages about missing entities in the run-time even + -- if we are compiling in -gnatc (no code generation) mode. + -- Similar processing applies to No_Run_Time_Mode. However, + -- don't do this if debug flag -gnatd.Z is set (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)); end if; Full_Analysis := True; Inside_A_Generic := False; In_Assertion_Expr := 0; + In_Default_Expr := False; In_Spec_Expression := False; Set_Comes_From_Source_Default (False); @@ -1483,13 +1506,7 @@ package body Sem is null; else - -- Initialize if first time - - if No (Comp_Unit_List) then - Comp_Unit_List := New_Elmt_List; - end if; - - Append_Elmt (Comp_Unit, Comp_Unit_List); + Append_New_Elmt (Comp_Unit, To => Comp_Unit_List); if Debug_Unit_Walk then Write_Str ("Appending "); @@ -1510,6 +1527,7 @@ package body Sem is Global_Discard_Names := S_Global_Dis_Names; GNAT_Mode := S_GNAT_Mode; In_Assertion_Expr := S_In_Assertion_Expr; + In_Default_Expr := S_In_Default_Expr; In_Spec_Expression := S_In_Spec_Expr; Inside_A_Generic := S_Inside_A_Generic; Outer_Generic_Scope := S_Outer_Gen_Scope; diff --git a/main/gcc/ada/sem.ads b/main/gcc/ada/sem.ads index 667fbc1dc85..e82905ea974 100644 --- a/main/gcc/ada/sem.ads +++ b/main/gcc/ada/sem.ads @@ -245,12 +245,18 @@ package Sem is In_Assertion_Expr : Nat := 0; -- This is set non-zero if we are within the expression of an assertion - -- pragma or aspect. It is a counter which is incremented at the start - -- of expanding such an expression, and decremented on completion of - -- expanding that expression. Probably a boolean would be good enough, - -- since we think that such expressions cannot nest, but that might not - -- be true in the future (e.g. if let expressions are added to Ada) so - -- we prepare for that future possibility by making it a counter. + -- pragma or aspect. It is a counter which is incremented at the start of + -- expanding such an expression, and decremented on completion of expanding + -- that expression. Probably a boolean would be good enough, since we think + -- that such expressions cannot nest, but that might not be true in the + -- future (e.g. if let expressions are added to Ada) so we prepare for that + -- future possibility by making it a counter. As with In_Spec_Expression, + -- it must be recursively saved and restored for a Semantics call. + + 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 + -- for a Semantics call. In_Inlined_Body : Boolean := False; -- Switch to indicate that we are analyzing and resolving an inlined body. @@ -486,6 +492,12 @@ package Sem is Save_SPARK_Mode_Pragma : Node_Id; -- Setting of SPARK_Mode_Pragma on entry to restore on exit + Save_Default_SSO : Character; + -- Setting of Default_SSO on entry to restore on exit + + Save_Uneval_Old : Character; + -- Setting of Uneval_Old on entry to restore on exit + Is_Transient : Boolean; -- Marks transient scopes (see Exp_Ch7 body for details) @@ -532,6 +544,9 @@ package Sem is -- Standard_Standard can be pushed anew on the scope stack to start a -- new active section (see comment above). + Locked_Shared_Objects : Elist_Id; + -- List of shared passive protected objects that have been locked in + -- this transient scope (always No_Elist for non-transient scopes). end record; package Scope_Stack is new Table.Table ( @@ -642,16 +657,18 @@ package Sem is -- external (more global) to it. procedure Enter_Generic_Scope (S : Entity_Id); - -- Shall be called each time a Generic subprogram or package scope is - -- entered. S is the entity of the scope. + -- Called each time a Generic subprogram or package scope is entered. S is + -- the entity of the scope. + -- -- ??? At the moment, only called for package specs because this mechanism -- is only used for avoiding freezing of external references in generics -- and this can only be an issue if the outer generic scope is a package -- spec (otherwise all external entities are already frozen) procedure Exit_Generic_Scope (S : Entity_Id); - -- Shall be called each time a Generic subprogram or package scope is - -- exited. S is the entity of the scope. + -- Called each time a Generic subprogram or package scope is exited. S is + -- the entity of the scope. + -- -- ??? At the moment, only called for package specs exit. function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean; @@ -666,13 +683,14 @@ package Sem is generic with procedure Action (Item : Node_Id); procedure Walk_Library_Items; - -- Primarily for use by CodePeer. Must be called after semantic analysis - -- (and expansion) are complete. Walks each relevant library item, calling - -- Action for each, in an order such that one will not run across forward - -- references. Each Item passed to Action is the declaration or body of - -- a library unit, including generics and renamings. The first item is - -- the N_Package_Declaration node for package Standard. Bodies are not - -- included, except for the main unit itself, which always comes last. + -- Primarily for use by CodePeer and GNATprove. Must be called after + -- semantic analysis (and expansion in the case of CodePeer) are complete. + -- Walks each relevant library item, calling Action for each, in an order + -- such that one will not run across forward references. Each Item passed + -- to Action is the declaration or body of a library unit, including + -- generics and renamings. The first item is the N_Package_Declaration node + -- for package Standard. Bodies are not included, except for the main unit + -- itself, which always comes last. -- -- Item is never a subunit -- diff --git a/main/gcc/ada/sem_aggr.adb b/main/gcc/ada/sem_aggr.adb index 0fe19377dbc..654f413c088 100644 --- a/main/gcc/ada/sem_aggr.adb +++ b/main/gcc/ada/sem_aggr.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; @@ -111,6 +112,8 @@ package body Sem_Aggr is -- Check that Expr is either not limited or else is one of the cases of -- expressions allowed for a limited component association (namely, an -- aggregate, function call, or <> notation). Report error for violations. + -- Expression is also OK in an instance or inlining context, because we + -- have already pre-analyzed and it is known to be type correct. procedure Check_Qualified_Aggregate (Level : Nat; Expr : Node_Id); -- Given aggregate Expr, check that sub-aggregates of Expr that are nested @@ -687,10 +690,13 @@ package body Sem_Aggr is begin if Is_Limited_Type (Etype (Expr)) and then Comes_From_Source (Expr) - and then not In_Instance_Body then - if not OK_For_Limited_Init (Etype (Expr), Expr) then - Error_Msg_N ("initialization not allowed for limited types", Expr); + if In_Instance_Body or else In_Inlined_Body then + null; + + elsif not OK_For_Limited_Init (Etype (Expr), Expr) then + Error_Msg_N + ("initialization not allowed for limited types", Expr); Explain_Limited_Type (Etype (Expr), Expr); end if; end if; @@ -707,7 +713,7 @@ package body Sem_Aggr is begin if Level = 0 then if Nkind (Parent (Expr)) /= N_Qualified_Expression then - Check_SPARK_Restriction ("aggregate should be qualified", Expr); + Check_SPARK_05_Restriction ("aggregate should be qualified", Expr); end if; else @@ -920,12 +926,12 @@ package body Sem_Aggr is and then not Is_Constrained (Etype (Name (Parent (N)))) then if not Is_Others_Aggregate (N) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("array aggregate should have only OTHERS", N); end if; elsif Is_Top_Level_Aggregate (N) then - Check_SPARK_Restriction ("aggregate should be qualified", N); + Check_SPARK_05_Restriction ("aggregate should be qualified", N); -- The legality of this unqualified aggregate is checked by calling -- Check_Qualified_Aggregate from one of its enclosing aggregate, @@ -993,7 +999,7 @@ package body Sem_Aggr is and then not Is_Private_Composite (Typ) and then not Is_Bit_Packed_Array (Typ) and then Nkind (Original_Node (Parent (N))) /= N_String_Literal - and then Is_Static_Subtype (Component_Type (Typ)) + and then Is_OK_Static_Subtype (Component_Type (Typ)) then declare Expr : Node_Id; @@ -1055,6 +1061,10 @@ package body Sem_Aggr is -- formal parameter. Consequently we also need to test for -- N_Procedure_Call_Statement or N_Function_Call. + -- The context may be an N_Reference node, created by expansion. + -- Legality of the others clause was established in the source, + -- so the context is legal. + Set_Etype (N, Aggr_Typ); -- May be overridden later on if Pkind = N_Assignment_Statement @@ -1070,6 +1080,7 @@ package body Sem_Aggr is Pkind = N_Component_Declaration or else Pkind = N_Parameter_Specification or else Pkind = N_Qualified_Expression or else + Pkind = N_Reference or else Pkind = N_Aggregate or else Pkind = N_Extension_Aggregate or else Pkind = N_Component_Association)) @@ -1611,10 +1622,12 @@ package body Sem_Aggr is end if; -- If the expression has been marked as requiring a range check, - -- then generate it here. + -- then generate it here. It's a bit odd to be generating such + -- checks in the analyzer, but harmless since Generate_Range_Check + -- does nothing (other than making sure Do_Range_Check is set) if + -- the expander is not active. if Do_Range_Check (Expr) then - Set_Do_Range_Check (Expr, False); Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed); end if; @@ -1715,15 +1728,26 @@ package body Sem_Aggr is if Is_Type (E) and then Has_Predicates (E) then Freeze_Before (N, E); + if Has_Dynamic_Predicate_Aspect (E) then + Error_Msg_NE + ("subtype& has dynamic predicate, not allowed " + & "in aggregate choice", Choice, E); + + elsif not Is_OK_Static_Subtype (E) then + Error_Msg_NE + ("non-static subtype& has predicate, not allowed " + & "in aggregate choice", Choice, E); + end if; + -- If the subtype has a static predicate, replace the -- original choice with the list of individual values -- covered by the predicate. - if Present (Static_Predicate (E)) then + if Present (Static_Discrete_Predicate (E)) then Delete_Choice := True; New_Cs := New_List; - P := First (Static_Predicate (E)); + P := First (Static_Discrete_Predicate (E)); while Present (P) loop C := New_Copy (P); Set_Sloc (C, Sloc (Choice)); @@ -1870,6 +1894,14 @@ package body Sem_Aggr is elsif Nkind (Choice) = N_Subtype_Indication then Resolve_Discrete_Subtype_Indication (Choice, Index_Base); + if Has_Dynamic_Predicate_Aspect + (Entity (Subtype_Mark (Choice))) + then + Error_Msg_NE ("subtype& has dynamic predicate, " + & "not allowed in aggregate choice", + Choice, Entity (Subtype_Mark (Choice))); + end if; + -- Does the subtype indication evaluation raise CE? Get_Index_Bounds (Subtype_Mark (Choice), S_Low, S_High); @@ -1899,11 +1931,11 @@ package body Sem_Aggr is -- In SPARK, the choice must be static - if not (Is_Static_Expression (Choice) + if not (Is_OK_Static_Expression (Choice) or else (Nkind (Choice) = N_Range - and then Is_Static_Range (Choice))) + and then Is_OK_Static_Range (Choice))) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("choice should be static", Choice); end if; end if; @@ -2217,20 +2249,38 @@ package body Sem_Aggr is Hi_Val := Table (J - 1).Highest; if Lo_Val > Hi_Val + 1 then - Choice := Table (J).Lo; - if Hi_Val + 1 = Lo_Val - 1 then - Error_Msg_N - ("missing index value in array aggregate!", - Choice); - else - Error_Msg_N - ("missing index values in array aggregate!", - Choice); - end if; + declare + Error_Node : Node_Id; + + begin + -- If the choice is the bound of a range in + -- a subtype indication, it is not in the + -- source lists for the aggregate itself, so + -- post the error on the aggregate. Otherwise + -- post it on choice itself. + + Choice := Table (J).Choice; + + if Is_List_Member (Choice) then + Error_Node := Choice; + else + Error_Node := N; + end if; + + if Hi_Val + 1 = Lo_Val - 1 then + Error_Msg_N + ("missing index value " + & "in array aggregate!", Error_Node); + else + Error_Msg_N + ("missing index values " + & "in array aggregate!", Error_Node); + end if; - Output_Bad_Choices - (Hi_Val + 1, Lo_Val - 1, Choice); + Output_Bad_Choices + (Hi_Val + 1, Lo_Val - 1, Error_Node); + end; end if; end loop; end if; @@ -2695,7 +2745,7 @@ package body Sem_Aggr is if Is_Entity_Name (A) and then Is_Type (Entity (A)) then - Check_SPARK_Restriction ("ancestor part cannot be a type mark", A); + Check_SPARK_05_Restriction ("ancestor part cannot be a type mark", A); -- AI05-0115: if the ancestor part is a subtype mark, the ancestor -- must not have unknown discriminants. @@ -3119,6 +3169,7 @@ package body Sem_Aggr is Consider_Others_Choice : Boolean := False) return Node_Id is + Typ : constant Entity_Id := Etype (Compon); Assoc : Node_Id; Expr : Node_Id := Empty; Selector_Name : Node_Id; @@ -3166,15 +3217,15 @@ package body Sem_Aggr is end if; else - if Present (Others_Etype) and then - Base_Type (Others_Etype) /= Base_Type (Etype - (Compon)) + if Present (Others_Etype) + and then Base_Type (Others_Etype) /= Base_Type (Typ) then - Error_Msg_N ("components in OTHERS choice must " & - "have same type", Selector_Name); + Error_Msg_N + ("components in OTHERS choice must " + & "have same type", Selector_Name); end if; - Others_Etype := Etype (Compon); + Others_Etype := Typ; if Expander_Active then return @@ -3220,15 +3271,42 @@ package body Sem_Aggr is -- initialized, but an association for the component -- exists, and it is not covered by an others clause. + -- Scalar and private types have no initialization + -- procedure, so they remain uninitialized. If the + -- target of the aggregate is a constant this + -- deserves a warning. + + if No (Expression (Parent (Compon))) + and then not Has_Non_Null_Base_Init_Proc (Typ) + and then not Has_Aspect (Typ, Aspect_Default_Value) + and then not Is_Concurrent_Type (Typ) + and then Nkind (Parent (N)) = N_Object_Declaration + and then Constant_Present (Parent (N)) + then + Error_Msg_Node_2 := Typ; + Error_Msg_NE + ("component&? of type& is uninitialized", + Assoc, Selector_Name); + + -- An additional reminder if the component type + -- is a generic formal. + + if Is_Generic_Type (Base_Type (Typ)) then + Error_Msg_NE + ("\instance should provide actual " + & "type with initialization for&", + Assoc, Typ); + end if; + end if; + return New_Copy_Tree_And_Copy_Dimensions (Expression (Parent (Compon))); else if Present (Next (Selector_Name)) then - Expr := - New_Copy_Tree_And_Copy_Dimensions - (Expression (Assoc)); + Expr := New_Copy_Tree_And_Copy_Dimensions + (Expression (Assoc)); else Expr := Expression (Assoc); end if; @@ -3425,10 +3503,12 @@ package body Sem_Aggr is end if; -- If the expression has been marked as requiring a range check, then - -- generate it here. + -- generate it here. It's a bit odd to be generating such checks in + -- the analyzer, but harmless since Generate_Range_Check does nothing + -- (other than making sure Do_Range_Check is set) if the expander is + -- not active. if Do_Range_Check (Expr) then - Set_Do_Range_Check (Expr, False); Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed); end if; @@ -3461,7 +3541,7 @@ package body Sem_Aggr is then if Present (Expressions (N)) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("named association cannot follow positional one", First (Choices (First (Component_Associations (N))))); end if; @@ -3473,13 +3553,13 @@ package body Sem_Aggr is Assoc := First (Component_Associations (N)); while Present (Assoc) loop if List_Length (Choices (Assoc)) > 1 then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("component association in record aggregate must " & "contain a single choice", Assoc); end if; if Nkind (First (Choices (Assoc))) = N_Others_Choice then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("record aggregate cannot contain OTHERS", Assoc); end if; @@ -3933,21 +4013,6 @@ package body Sem_Aggr is -- Typ is not a derived tagged type else - -- A type derived from an untagged private type whose full view - -- has discriminants is constructed as a record type but there - -- are no legal aggregates for it. - - if Is_Derived_Type (Typ) - and then Has_Private_Ancestor (Typ) - and then Nkind (N) /= N_Extension_Aggregate - then - Error_Msg_Node_2 := Base_Type (Etype (Typ)); - Error_Msg_NE - ("no aggregate available for type& derived from " - & "private type&", N, Typ); - return; - end if; - Record_Def := Type_Definition (Parent (Base_Type (Typ))); if Null_Present (Record_Def) then @@ -4330,13 +4395,12 @@ package body Sem_Aggr is end if; if Needs_Box then - Append - (Make_Component_Association (Loc, - Choices => - New_List (Make_Others_Choice (Loc)), - Expression => Empty, - Box_Present => True), - Component_Associations (Aggr)); + 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; @@ -4375,14 +4439,14 @@ package body Sem_Aggr is while Present (Comp) loop if Ekind (Comp) = E_Component then if not Is_Record_Type (Etype (Comp)) then - Append - (Make_Component_Association (Loc, + Append_To + (Component_Associations (Expr), + Make_Component_Association (Loc, Choices => New_List (Make_Others_Choice (Loc)), Expression => Empty, - Box_Present => True), - Component_Associations (Expr)); + Box_Present => True)); end if; exit; end if; diff --git a/main/gcc/ada/sem_attr.adb b/main/gcc/ada/sem_attr.adb index 9cb42b956b9..cdb3cfe33c2 100644 --- a/main/gcc/ada/sem_attr.adb +++ b/main/gcc/ada/sem_attr.adb @@ -65,6 +65,7 @@ with Sem_Util; use Sem_Util; with Stand; use Stand; with Sinfo; use Sinfo; with Sinput; use Sinput; +with System; with Stringt; use Stringt; with Style; with Stylesw; use Stylesw; @@ -86,65 +87,77 @@ package body Sem_Attr is -- used so that we can abandon the processing so we don't run into -- trouble with cascaded errors. - -- The following array is the list of attributes defined in the Ada 83 RM - -- that are not included in Ada 95, but still get recognized in GNAT. + -- The following array is the list of attributes defined in the Ada 83 RM. + -- In Ada 83 mode, these are the only recognized attributes. In other Ada + -- modes all these attributes are recognized, even if removed in Ada 95. Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Address | - Attribute_Aft | - Attribute_Alignment | - Attribute_Base | - Attribute_Callable | - Attribute_Constrained | - Attribute_Count | - Attribute_Delta | - Attribute_Digits | - Attribute_Emax | - Attribute_Epsilon | - Attribute_First | - Attribute_First_Bit | - Attribute_Fore | - Attribute_Image | - Attribute_Large | - Attribute_Last | - Attribute_Last_Bit | - Attribute_Leading_Part | - Attribute_Length | - Attribute_Machine_Emax | - Attribute_Machine_Emin | - Attribute_Machine_Mantissa | - Attribute_Machine_Overflows | - Attribute_Machine_Radix | - Attribute_Machine_Rounds | - Attribute_Mantissa | - Attribute_Pos | - Attribute_Position | - Attribute_Pred | - Attribute_Range | - Attribute_Safe_Emax | - Attribute_Safe_Large | - Attribute_Safe_Small | - Attribute_Size | - Attribute_Small | - Attribute_Storage_Size | - Attribute_Succ | - Attribute_Terminated | - Attribute_Val | - Attribute_Value | - Attribute_Width => True, - others => False); + Attribute_Address | + Attribute_Aft | + Attribute_Alignment | + Attribute_Base | + Attribute_Callable | + Attribute_Constrained | + Attribute_Count | + Attribute_Delta | + Attribute_Digits | + Attribute_Emax | + Attribute_Epsilon | + Attribute_First | + Attribute_First_Bit | + Attribute_Fore | + Attribute_Image | + Attribute_Large | + Attribute_Last | + Attribute_Last_Bit | + Attribute_Leading_Part | + Attribute_Length | + Attribute_Machine_Emax | + Attribute_Machine_Emin | + Attribute_Machine_Mantissa | + Attribute_Machine_Overflows | + Attribute_Machine_Radix | + Attribute_Machine_Rounds | + Attribute_Mantissa | + Attribute_Pos | + Attribute_Position | + Attribute_Pred | + Attribute_Range | + Attribute_Safe_Emax | + Attribute_Safe_Large | + Attribute_Safe_Small | + Attribute_Size | + Attribute_Small | + Attribute_Storage_Size | + Attribute_Succ | + Attribute_Terminated | + Attribute_Val | + Attribute_Value | + Attribute_Width => True, + others => False); -- The following array is the list of attributes defined in the Ada 2005 -- RM which are not defined in Ada 95. These are recognized in Ada 95 mode, -- but in Ada 95 they are considered to be implementation defined. Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Machine_Rounding | - Attribute_Mod | - Attribute_Priority | - Attribute_Stream_Size | - Attribute_Wide_Wide_Width => True, - others => False); + Attribute_Machine_Rounding | + Attribute_Mod | + Attribute_Priority | + Attribute_Stream_Size | + Attribute_Wide_Wide_Width => True, + others => False); + + -- The following array is the list of attributes defined in the Ada 2012 + -- RM which are not defined in Ada 2005. These are recognized in Ada 95 + -- and Ada 2005 modes, but are considered to be implementation defined. + + Attribute_12 : constant Attribute_Class_Array := Attribute_Class_Array'( + Attribute_First_Valid | + Attribute_Has_Same_Storage | + Attribute_Last_Valid | + Attribute_Max_Alignment_For_Allocation => True, + others => False); -- The following array contains all attributes that imply a modification -- of their prefixes or result in an access value. Such prefixes can be @@ -152,13 +165,13 @@ package body Sem_Attr is Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array := Attribute_Class_Array'( - Attribute_Access | - Attribute_Address | - Attribute_Input | - Attribute_Read | - Attribute_Unchecked_Access | - Attribute_Unrestricted_Access => True, - others => False); + Attribute_Access | + Attribute_Address | + Attribute_Input | + Attribute_Read | + Attribute_Unchecked_Access | + Attribute_Unrestricted_Access => True, + others => False); ----------------------- -- Local_Subprograms -- @@ -180,8 +193,7 @@ package body Sem_Attr is function Is_Anonymous_Tagged_Base (Anon : Entity_Id; - Typ : Entity_Id) - return Boolean; + Typ : Entity_Id) return Boolean; -- For derived tagged types that constrain parent discriminants we build -- an anonymous unconstrained base type. We need to recognize the relation -- between the two when analyzing an access attribute for a constrained @@ -235,11 +247,6 @@ package body Sem_Attr is -- for internally generated uses of the attributes. This legality rule -- only applies to scalar types. - procedure Check_Ada_2012_Attribute; - -- Check that we are in Ada 2012 mode for an Ada 2012 attribute, and - -- issue appropriate messages if not (and return to caller even in - -- the error case). - procedure Check_Array_Or_Scalar_Type; -- Common procedure used by First, Last, Range attribute to check -- that the prefix is a constrained array or scalar type, or a name @@ -314,7 +321,7 @@ package body Sem_Attr is -- Verify that prefix of attribute N is a float type and that -- two attribute expressions are present - procedure Check_SPARK_Restriction_On_Attribute; + procedure Check_SPARK_05_Restriction_On_Attribute; -- Issue an error in formal mode because attribute N is allowed procedure Check_Integer_Type; @@ -406,7 +413,14 @@ package body Sem_Attr is procedure Standard_Attribute (Val : Int); -- Used to process attributes whose prefix is package Standard which -- yield values of type Universal_Integer. The attribute reference - -- node is rewritten with an integer literal of the given value. + -- node is rewritten with an integer literal of the given value which + -- is marked as static. + + procedure Uneval_Old_Msg; + -- Called when Loop_Entry or Old is used in a potentially unevaluated + -- expression. Generates appropriate message or warning depending on + -- the setting of Opt.Uneval_Old (or flags in an N_Aspect_Specification + -- node in the aspect case). procedure Unexpected_Argument (En : Node_Id); -- Signal unexpected attribute argument (En is the argument) @@ -523,18 +537,6 @@ package body Sem_Attr is end if; end; - -- Allow Address if the prefix is a reference to the AST_Entry - -- attribute. If expansion is active, the attribute will be - -- replaced by a function call, and address will work fine and - -- get the proper value, but if expansion is not active, then - -- the check here allows proper semantic analysis of the reference. - - elsif Nkind (P) = N_Attribute_Reference - and then Attribute_Name (P) = Name_AST_Entry - then - Rewrite (N, - New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N))); - -- Object is OK elsif Is_Object_Reference (P) then @@ -754,7 +756,7 @@ package body Sem_Attr is -- Start of processing for Analyze_Access_Attribute begin - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_E0; if Nkind (P) = N_Character_Literal then @@ -1003,7 +1005,13 @@ package body Sem_Attr is -- pointer can be used to modify the variable, and we might -- not detect this, leading to some junk warnings. - Set_Never_Set_In_Source (Ent, False); + -- We only do this for source references, since otherwise + -- we can suppress warnings, e.g. from the unrestricted + -- access generated for validity checks in -gnatVa mode. + + if Comes_From_Source (N) then + Set_Never_Set_In_Source (Ent, False); + end if; -- Mark entity as address taken, and kill current values @@ -1076,16 +1084,6 @@ package body Sem_Attr is end if; end Bad_Attribute_For_Predicate; - ------------------------------ - -- Check_Ada_2012_Attribute -- - ------------------------------ - - procedure Check_Ada_2012_Attribute is - begin - Error_Msg_Name_1 := Aname; - Error_Msg_Ada_2012_Feature ("attribute %", Sloc (N)); - end Check_Ada_2012_Attribute; - -------------------------------- -- Check_Array_Or_Scalar_Type -- -------------------------------- @@ -1241,7 +1239,7 @@ package body Sem_Attr is Resolve (E1, Any_Integer); Set_Etype (E1, Standard_Integer); - if not Is_Static_Expression (E1) + if not Is_OK_Static_Expression (E1) or else Raises_Constraint_Error (E1) then Flag_Non_Static_Expr @@ -1480,7 +1478,6 @@ package body Sem_Attr is procedure Check_First_Last_Valid is begin - Check_Ada_2012_Attribute; Check_Discrete_Type; -- Freeze the subtype now, so that the following test for predicates @@ -1491,7 +1488,7 @@ package body Sem_Attr is -- Now test for dynamic predicate if Has_Predicates (P_Type) - and then No (Static_Predicate (P_Type)) + and then not (Has_Static_Predicate (P_Type)) then Error_Attr_P ("prefix of % attribute may not have dynamic predicate"); @@ -1499,7 +1496,7 @@ package body Sem_Attr is -- Check non-static subtype - if not Is_Static_Subtype (P_Type) then + if not Is_OK_Static_Subtype (P_Type) then Error_Attr_P ("prefix of % attribute must be a static subtype"); end if; @@ -1508,7 +1505,8 @@ package body Sem_Attr is if Expr_Value (Type_Low_Bound (P_Type)) > Expr_Value (Type_High_Bound (P_Type)) or else (Has_Predicates (P_Type) - and then Is_Empty_List (Static_Predicate (P_Type))) + and then + Is_Empty_List (Static_Discrete_Predicate (P_Type))) then Error_Attr_P ("prefix of % attribute must be subtype with " @@ -1813,14 +1811,14 @@ package body Sem_Attr is end Check_Scalar_Type; ------------------------------------------ - -- Check_SPARK_Restriction_On_Attribute -- + -- Check_SPARK_05_Restriction_On_Attribute -- ------------------------------------------ - procedure Check_SPARK_Restriction_On_Attribute is + procedure Check_SPARK_05_Restriction_On_Attribute is begin Error_Msg_Name_1 := Aname; - Check_SPARK_Restriction ("attribute % is not allowed", P); - end Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction ("attribute % is not allowed", P); + end Check_SPARK_05_Restriction_On_Attribute; --------------------------- -- Check_Standard_Prefix -- @@ -2260,8 +2258,69 @@ package body Sem_Attr is Check_Standard_Prefix; Rewrite (N, Make_Integer_Literal (Loc, Val)); Analyze (N); + Set_Is_Static_Expression (N, True); end Standard_Attribute; + -------------------- + -- Uneval_Old_Msg -- + -------------------- + + procedure Uneval_Old_Msg is + Uneval_Old_Setting : Character; + Prag : Node_Id; + + begin + -- If from aspect, then Uneval_Old_Setting comes from flags in the + -- N_Aspect_Specification node that corresponds to the attribute. + + -- First find the pragma in which we appear (note that at this stage, + -- even if we appeared originally within an aspect specification, we + -- are now within the corresponding pragma). + + Prag := N; + loop + Prag := Parent (Prag); + exit when No (Prag) or else Nkind (Prag) = N_Pragma; + end loop; + + if Present (Prag) then + if Uneval_Old_Accept (Prag) then + Uneval_Old_Setting := 'A'; + elsif Uneval_Old_Warn (Prag) then + Uneval_Old_Setting := 'W'; + else + Uneval_Old_Setting := 'E'; + end if; + + -- If we did not find the pragma, that's odd, just use the setting + -- from Opt.Uneval_Old. Perhaps this is due to a previous error? + + else + Uneval_Old_Setting := Opt.Uneval_Old; + end if; + + -- Processing depends on the setting of Uneval_Old + + case Uneval_Old_Setting is + when 'E' => + Error_Attr_P + ("prefix of attribute % that is potentially " + & "unevaluated must denote an entity"); + + when 'W' => + Error_Msg_Name_1 := Aname; + Error_Msg_F + ("??prefix of attribute % appears in potentially " + & "unevaluated context, exception may be raised", P); + + when 'A' => + null; + + when others => + raise Program_Error; + end case; + end Uneval_Old_Msg; + ------------------------- -- Unexpected Argument -- ------------------------- @@ -2312,9 +2371,14 @@ package body Sem_Attr is end if; end if; - -- Deal with Ada 2005 attributes that are + -- Deal with Ada 2005 attributes that are implementation attributes + -- because they appear in a version of Ada before Ada 2005, and + -- similarly for Ada 2012 attributes appearing in an earlier version. - if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then + if (Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005) + or else + (Attribute_12 (Attr_Id) and then Ada_Version < Ada_2012) + then Check_Restriction (No_Implementation_Attributes, N); end if; @@ -2445,7 +2509,7 @@ package body Sem_Attr is -- parameterless call. Entry attributes are handled specially below. if Is_Entity_Name (P) - and then not Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry) + and then not Nam_In (Aname, Name_Count, Name_Caller) then Check_Parameterless_Call (P); end if; @@ -2453,10 +2517,10 @@ package body Sem_Attr is if Is_Overloaded (P) then -- Ada 2005 (AI-345): Since protected and task types have - -- primitive entry wrappers, the attributes Count, Caller and - -- AST_Entry require a context check + -- primitive entry wrappers, the attributes Count, and Caller + -- require a context check - if Nam_In (Aname, Name_Count, Name_Caller, Name_AST_Entry) then + if Nam_In (Aname, Name_Count, Name_Caller) then declare Count : Natural := 0; I : Interp_Index; @@ -2499,7 +2563,7 @@ package body Sem_Attr is and then not In_Open_Scopes (Scope (P_Type)) and then not In_Spec_Expression then - Check_SPARK_Restriction ("invisible attribute of type", N); + Check_SPARK_05_Restriction ("invisible attribute of type", N); end if; -- Remaining processing depends on attribute @@ -2628,129 +2692,6 @@ package body Sem_Attr is Set_Etype (N, RTE (RE_Asm_Output_Operand)); - --------------- - -- AST_Entry -- - --------------- - - when Attribute_AST_Entry => AST_Entry : declare - Ent : Entity_Id; - Pref : Node_Id; - Ptyp : Entity_Id; - - Indexed : Boolean; - -- Indicates if entry family index is present. Note the coding - -- here handles the entry family case, but in fact it cannot be - -- executed currently, because pragma AST_Entry does not permit - -- the specification of an entry family. - - procedure Bad_AST_Entry; - -- Signal a bad AST_Entry pragma - - function OK_Entry (E : Entity_Id) return Boolean; - -- Checks that E is of an appropriate entity kind for an entry - -- (i.e. E_Entry if Index is False, or E_Entry_Family if Index - -- is set True for the entry family case). In the True case, - -- makes sure that Is_AST_Entry is set on the entry. - - ------------------- - -- Bad_AST_Entry -- - ------------------- - - procedure Bad_AST_Entry is - begin - Error_Attr_P ("prefix for % attribute must be task entry"); - end Bad_AST_Entry; - - -------------- - -- OK_Entry -- - -------------- - - function OK_Entry (E : Entity_Id) return Boolean is - Result : Boolean; - - begin - if Indexed then - Result := (Ekind (E) = E_Entry_Family); - else - Result := (Ekind (E) = E_Entry); - end if; - - if Result then - if not Is_AST_Entry (E) then - Error_Msg_Name_2 := Aname; - Error_Attr ("% attribute requires previous % pragma", P); - end if; - end if; - - return Result; - end OK_Entry; - - -- Start of processing for AST_Entry - - begin - Check_VMS (N); - Check_E0; - - -- Deal with entry family case - - if Nkind (P) = N_Indexed_Component then - Pref := Prefix (P); - Indexed := True; - else - Pref := P; - Indexed := False; - end if; - - Ptyp := Etype (Pref); - - if Ptyp = Any_Type or else Error_Posted (Pref) then - return; - end if; - - -- If the prefix is a selected component whose prefix is of an - -- access type, then introduce an explicit dereference. - -- ??? Could we reuse Check_Dereference here? - - if Nkind (Pref) = N_Selected_Component - and then Is_Access_Type (Ptyp) - then - Rewrite (Pref, - Make_Explicit_Dereference (Sloc (Pref), - Relocate_Node (Pref))); - Analyze_And_Resolve (Pref, Designated_Type (Ptyp)); - end if; - - -- Prefix can be of the form a.b, where a is a task object - -- and b is one of the entries of the corresponding task type. - - if Nkind (Pref) = N_Selected_Component - and then OK_Entry (Entity (Selector_Name (Pref))) - and then Is_Object_Reference (Prefix (Pref)) - and then Is_Task_Type (Etype (Prefix (Pref))) - then - null; - - -- Otherwise the prefix must be an entry of a containing task, - -- or of a variable of the enclosing task type. - - else - if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then - Ent := Entity (Pref); - - if not OK_Entry (Ent) - or else not In_Open_Scopes (Scope (Ent)) - then - Bad_AST_Entry; - end if; - - else - Bad_AST_Entry; - end if; - end if; - - Set_Etype (N, RTE (RE_AST_Handler)); - end AST_Entry; - ----------------------------- -- Atomic_Always_Lock_Free -- ----------------------------- @@ -2792,7 +2733,7 @@ package body Sem_Attr is if Nkind (Parent (N)) /= N_Attribute_Reference then Error_Msg_Name_1 := Aname; - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("attribute% is only allowed as prefix of another attribute", P); end if; @@ -2998,6 +2939,7 @@ package body Sem_Attr is Check_Standard_Prefix; Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String)); Analyze_And_Resolve (N, Standard_String); + Set_Is_Static_Expression (N, True); -------------------- -- Component_Size -- @@ -3048,9 +2990,7 @@ package body Sem_Attr is -- because it was valid in the generic unit. Ditto if this is -- an inlining of a function declared in an instance. - if In_Instance - or else In_Inlined_Body - then + if In_Instance or else In_Inlined_Body then return; -- For sure OK if we have a real private type itself, but must @@ -3195,12 +3135,10 @@ package body Sem_Attr is -- The prefix denotes either the task type, or else a -- single task whose task type is being analyzed. - if (Is_Type (Tsk) - and then Tsk = S) - + if (Is_Type (Tsk) and then Tsk = S) or else (not Is_Type (Tsk) - and then Etype (Tsk) = S - and then not (Comes_From_Source (S))) + and then Etype (Tsk) = S + and then not (Comes_From_Source (S))) then null; else @@ -3231,7 +3169,6 @@ package body Sem_Attr is begin Get_First_Interp (P, Index, It); - while Present (It.Nam) loop if It.Nam = Ent then null; @@ -3260,22 +3197,57 @@ package body Sem_Attr is -- Default_Bit_Order -- ----------------------- - when Attribute_Default_Bit_Order => Default_Bit_Order : + when Attribute_Default_Bit_Order => Default_Bit_Order : declare + Target_Default_Bit_Order : System.Bit_Order; + begin Check_Standard_Prefix; if Bytes_Big_Endian then - Rewrite (N, - Make_Integer_Literal (Loc, False_Value)); + Target_Default_Bit_Order := System.High_Order_First; else - Rewrite (N, - Make_Integer_Literal (Loc, True_Value)); + Target_Default_Bit_Order := System.Low_Order_First; end if; + Rewrite (N, + Make_Integer_Literal (Loc, + UI_From_Int (System.Bit_Order'Pos (Target_Default_Bit_Order)))); + Set_Etype (N, Universal_Integer); Set_Is_Static_Expression (N); end Default_Bit_Order; + ---------------------------------- + -- Default_Scalar_Storage_Order -- + ---------------------------------- + + when Attribute_Default_Scalar_Storage_Order => Default_SSO : declare + RE_Default_SSO : RE_Id; + + begin + Check_Standard_Prefix; + + case Opt.Default_SSO is + when ' ' => + if Bytes_Big_Endian then + RE_Default_SSO := RE_High_Order_First; + else + RE_Default_SSO := RE_Low_Order_First; + end if; + + when 'H' => + RE_Default_SSO := RE_High_Order_First; + + when 'L' => + RE_Default_SSO := RE_Low_Order_First; + + when others => + raise Program_Error; + end case; + + Rewrite (N, New_Occurrence_Of (RTE (RE_Default_SSO), Loc)); + end Default_SSO; + -------------- -- Definite -- -------------- @@ -3306,9 +3278,7 @@ package body Sem_Attr is when Attribute_Descriptor_Size => Check_E0; - if not Is_Entity_Name (P) - or else not Is_Type (Entity (P)) - then + if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then Error_Attr_P ("prefix of attribute % must denote a type"); end if; @@ -3410,8 +3380,7 @@ package body Sem_Attr is else if not Is_Entity_Name (P) or else (not Is_Object (Entity (P)) - and then - Ekind (Entity (P)) /= E_Enumeration_Literal) + and then Ekind (Entity (P)) /= E_Enumeration_Literal) then Error_Attr_P ("prefix of % attribute must be " & @@ -3576,7 +3545,6 @@ package body Sem_Attr is ---------------------- when Attribute_Has_Same_Storage => - Check_Ada_2012_Attribute; Check_E1; -- The arguments must be objects of any type @@ -3614,8 +3582,8 @@ package body Sem_Attr is if Etype (P) = Standard_Exception_Type then Set_Etype (N, RTE (RE_Exception_Id)); - -- Ada 2005 (AI-345): Attribute 'Identity may be applied to - -- task interface class-wide types. + -- Ada 2005 (AI-345): Attribute 'Identity may be applied to task + -- interface class-wide types. elsif Is_Task_Type (Etype (P)) or else (Is_Access_Type (Etype (P)) @@ -3645,7 +3613,7 @@ package body Sem_Attr is when Attribute_Image => Image : begin - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_Scalar_Type; Set_Etype (N, Standard_String); @@ -4101,26 +4069,24 @@ package body Sem_Attr is and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id then Error_Attr_P - ("prefix of attribute % that applies to " - & "outer loop must denote an entity"); + ("prefix of attribute % that applies to outer loop must denote " + & "an entity"); elsif Is_Potentially_Unevaluated (P) then - Error_Attr_P - ("prefix of attribute % that is potentially " - & "unevaluated must denote an entity"); + Uneval_Old_Msg; end if; - -- Finally, if the Loop_Entry attribute appears within a pragma - -- that is ignored, we replace P'Loop_Entity by P to avoid useless - -- generation of the loop entity variable. Note that in this case - -- the expression won't be executed anyway, and this substitution - -- keeps types happy! - - -- We should really do this in the expander, but it's easier here + -- Replace the Loop_Entry attribute reference by its prefix if the + -- related pragma is ignored. This transformation is OK with respect + -- to typing because Loop_Entry's type is that of its prefix. This + -- early transformation also avoids the generation of a useless loop + -- entry constant. if Is_Ignored (Enclosing_Pragma) then Rewrite (N, Relocate_Node (P)); end if; + + Preanalyze_And_Resolve (P); end Loop_Entry; ------------- @@ -4256,7 +4222,7 @@ package body Sem_Attr is Resolve (E1, Any_Integer); Set_Etype (E1, Standard_Integer); - if not Is_Static_Expression (E1) then + if not Is_OK_Static_Expression (E1) then Flag_Non_Static_Expr ("expression for parameter number must be static!", E1); Error_Attr; @@ -4531,25 +4497,11 @@ package body Sem_Attr is -- Ensure that the obtained expression is the consequence of a -- contract case as this is the only postcondition-like part of - -- the pragma. - - if Expr = Expression (Parent (Expr)) then + -- the pragma. Otherwise, attribute 'Old appears in the condition + -- of a contract case. Emit an error since this is not a + -- postcondition-like context. (SPARK RM 6.1.3(2)) - -- Warn that a potentially unevaluated prefix is always - -- evaluated when the corresponding consequence is selected. - - if Is_Potentially_Unevaluated (P) then - Error_Msg_Name_1 := Aname; - Error_Msg_N - ("??prefix of attribute % is always evaluated when " - & "related consequence is selected", P); - end if; - - -- Attribute 'Old appears in the condition of a contract case. - -- Emit an error since this is not a postcondition-like context. - -- (SPARK RM 6.1.3(2)) - - else + if Expr /= Expression (Parent (Expr)) then Error_Attr ("attribute % cannot appear in the condition " & "of a contract case", P); @@ -4612,7 +4564,10 @@ package body Sem_Attr is -- process of being preanalyzed. Perform the semantic checks now -- before the pragma is relocated and/or expanded. - if In_Spec_Expression then + -- For a generic subprogram, postconditions are preanalyzed as well + -- for name capture, and still appear within an aspect spec. + + if In_Spec_Expression or Inside_A_Generic then Prag := N; while Present (Prag) and then not Nkind_In (Prag, N_Aspect_Specification, @@ -4625,10 +4580,11 @@ package body Sem_Attr is end loop; -- In ASIS mode, the aspect itself is analyzed, in addition to the - -- corresponding pragma. Do not issue errors when analyzing the - -- aspect. + -- corresponding pragma. Don't issue errors when analyzing aspect. - if Nkind (Prag) = N_Aspect_Specification then + if Nkind (Prag) = N_Aspect_Specification + and then Chars (Identifier (Prag)) = Name_Post + then null; -- In all other cases the related context must be a pragma @@ -4740,17 +4696,14 @@ package body Sem_Attr is ("??attribute Old applied to constant has no effect", P); end if; - -- Check that the prefix of 'Old is an entity, when it appears in - -- a postcondition and may be potentially unevaluated (6.1.1 (27/3)). + -- Check that the prefix of 'Old is an entity when it may be + -- potentially unevaluated (6.1.1 (27/3)). if Present (Prag) - and then Get_Pragma_Id (Prag) = Pragma_Postcondition and then Is_Potentially_Unevaluated (N) and then not Is_Entity_Name (P) then - Error_Attr_P - ("prefix of attribute % that is potentially unevaluated must " - & "denote an entity"); + Uneval_Old_Msg; end if; -- The attribute appears within a pre/postcondition, but refers to @@ -4859,7 +4812,7 @@ package body Sem_Attr is if Is_Boolean_Type (P_Type) then Error_Msg_Name_1 := Aname; Error_Msg_Name_2 := Chars (P_Type); - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("attribute% is not allowed for type%", P); end if; @@ -4885,7 +4838,8 @@ package body Sem_Attr is if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then Error_Msg_Name_1 := Aname; Error_Msg_Name_2 := Chars (P_Type); - Check_SPARK_Restriction ("attribute% is not allowed for type%", P); + Check_SPARK_05_Restriction + ("attribute% is not allowed for type%", P); end if; Resolve (E1, P_Base_Type); @@ -4896,10 +4850,8 @@ package body Sem_Attr is -- make an exception in Check_Float_Overflow mode. if Is_Floating_Point_Type (P_Type) then - if Check_Float_Overflow - and then not Range_Checks_Suppressed (P_Base_Type) - then - Enable_Range_Check (E1); + if not Range_Checks_Suppressed (P_Base_Type) then + Set_Do_Range_Check (E1); end if; -- If not modular type, test for overflow check required @@ -5461,7 +5413,7 @@ package body Sem_Attr is when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare - Ent : Entity_Id := Empty; + Ent : Entity_Id := Empty; begin Check_E0; @@ -5474,7 +5426,7 @@ package body Sem_Attr is -- the default bit order for the target. if not (GNAT_Mode and then Is_Generic_Type (P_Type)) - and then not In_Instance + and then not In_Instance then Error_Attr_P ("prefix of % attribute must be record or array type"); @@ -5778,7 +5730,8 @@ package body Sem_Attr is if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then Error_Msg_Name_1 := Aname; Error_Msg_Name_2 := Chars (P_Type); - Check_SPARK_Restriction ("attribute% is not allowed for type%", P); + Check_SPARK_05_Restriction + ("attribute% is not allowed for type%", P); end if; Resolve (E1, P_Base_Type); @@ -5789,10 +5742,8 @@ package body Sem_Attr is -- make an exception in Check_Float_Overflow mode. if Is_Floating_Point_Type (P_Type) then - if Check_Float_Overflow - and then not Range_Checks_Suppressed (P_Base_Type) - then - Enable_Range_Check (E1); + if not Range_Checks_Suppressed (P_Base_Type) then + Set_Do_Range_Check (E1); end if; -- If not modular type, test for overflow check required @@ -5870,6 +5821,7 @@ package body Sem_Attr is Make_String_Literal (Loc, Strval => TN (TN'First .. TL))); Analyze_And_Resolve (N, Standard_String); + Set_Is_Static_Expression (N, True); end Target_Name; ---------------- @@ -5897,7 +5849,11 @@ package body Sem_Attr is Analyze_And_Resolve (E1, Any_Integer); Set_Etype (N, RTE (RE_Address)); - -- Static expression case, check range and set appropriate type + if Is_Static_Expression (E1) then + Set_Is_Static_Expression (N, True); + end if; + + -- OK static expression case, check range and set appropriate type if Is_OK_Static_Expression (E1) then Val := Expr_Value (E1); @@ -5927,6 +5883,8 @@ package body Sem_Attr is Set_Etype (E1, Standard_Unsigned_64); end if; end if; + + Set_Is_Static_Expression (N, True); end To_Address; ------------ @@ -6047,6 +6005,7 @@ package body Sem_Attr is Check_Type; Check_Not_Incomplete_Type; Set_Etype (N, Standard_Boolean); + Set_Is_Static_Expression (N, True); ------------------------------ -- Universal_Literal_String -- @@ -6111,6 +6070,7 @@ package body Sem_Attr is Rewrite (N, Make_String_Literal (Loc, End_String)); Analyze (N); + Set_Is_Static_Expression (N, True); end; end if; end Universal_Literal_String; @@ -6162,69 +6122,158 @@ package body Sem_Attr is ------------ when Attribute_Update => Update : declare + Common_Typ : Entity_Id; + -- The common type of a multiple component update for a record + Comps : Elist_Id := No_Elist; - Expr : Node_Id; + -- A list used in the resolution of a record update. It contains the + -- entities of all record components processed so far. - procedure Check_Component_Reference - (Comp : Entity_Id; - Typ : Entity_Id); - -- Comp is a record component (possibly a discriminant) and Typ is a - -- record type. Determine whether Comp is a legal component of Typ. - -- Emit an error if Comp mentions a discriminant or is not a unique - -- component reference in the update aggregate. + procedure Analyze_Array_Component_Update (Assoc : Node_Id); + -- Analyze and resolve array_component_association Assoc against the + -- index of array type P_Type. - ------------------------------- - -- Check_Component_Reference -- - ------------------------------- + procedure Analyze_Record_Component_Update (Comp : Node_Id); + -- Analyze and resolve record_component_association Comp against + -- record type P_Type. - procedure Check_Component_Reference - (Comp : Entity_Id; - Typ : Entity_Id) - is - Comp_Name : constant Name_Id := Chars (Comp); + ------------------------------------ + -- Analyze_Array_Component_Update -- + ------------------------------------ - function Is_Duplicate_Component return Boolean; - -- Determine whether component Comp already appears in list Comps + procedure Analyze_Array_Component_Update (Assoc : Node_Id) is + Expr : Node_Id; + High : Node_Id; + Index : Node_Id; + Index_Typ : Entity_Id; + Low : Node_Id; - ---------------------------- - -- Is_Duplicate_Component -- - ---------------------------- + begin + -- The current association contains a sequence of indexes denoting + -- an element of a multidimensional array: - function Is_Duplicate_Component return Boolean is - Comp_Elmt : Elmt_Id; + -- (Index_1, ..., Index_N) - begin - if Present (Comps) then - Comp_Elmt := First_Elmt (Comps); - while Present (Comp_Elmt) loop - if Chars (Node (Comp_Elmt)) = Comp_Name then - return True; + -- Examine each individual index and resolve it against the proper + -- index type of the array. + + if Nkind (First (Choices (Assoc))) = N_Aggregate then + Expr := First (Choices (Assoc)); + while Present (Expr) loop + + -- The use of others is illegal (SPARK RM 4.4.1(12)) + + if Nkind (Expr) = N_Others_Choice then + Error_Attr + ("others choice not allowed in attribute %", Expr); + + -- Otherwise analyze and resolve all indexes + + else + Index := First (Expressions (Expr)); + Index_Typ := First_Index (P_Type); + while Present (Index) and then Present (Index_Typ) loop + Analyze_And_Resolve (Index, Etype (Index_Typ)); + Next (Index); + Next_Index (Index_Typ); + end loop; + + -- Detect a case where the association either lacks an + -- index or contains an extra index. + + if Present (Index) or else Present (Index_Typ) then + Error_Msg_N + ("dimension mismatch in index list", Assoc); end if; + end if; - Next_Elmt (Comp_Elmt); - end loop; + Next (Expr); + end loop; + + -- The current association denotes either a single component or a + -- range of components of a one dimensional array: + + -- 1, 2 .. 5 + + -- Resolve the index or its high and low bounds (if range) against + -- the proper index type of the array. + + else + Index := First (Choices (Assoc)); + Index_Typ := First_Index (P_Type); + + if Present (Next_Index (Index_Typ)) then + Error_Msg_N ("too few subscripts in array reference", Assoc); end if; - return False; - end Is_Duplicate_Component; + while Present (Index) loop - -- Local variables + -- The use of others is illegal (SPARK RM 4.4.1(12)) - Comp_Or_Discr : Entity_Id; + if Nkind (Index) = N_Others_Choice then + Error_Attr + ("others choice not allowed in attribute %", Index); + + -- The index denotes a range of elements + + elsif Nkind (Index) = N_Range then + Low := Low_Bound (Index); + High := High_Bound (Index); + + Analyze_And_Resolve (Low, Etype (Index_Typ)); + Analyze_And_Resolve (High, Etype (Index_Typ)); + + -- Add a range check to ensure that the bounds of the + -- range are within the index type when this cannot be + -- determined statically. + + if not Is_OK_Static_Expression (Low) then + Set_Do_Range_Check (Low); + end if; + + if not Is_OK_Static_Expression (High) then + Set_Do_Range_Check (High); + end if; + + -- Otherwise the index denotes a single element + + else + Analyze_And_Resolve (Index, Etype (Index_Typ)); + + -- Add a range check to ensure that the index is within + -- the index type when it is not possible to determine + -- this statically. + + if not Is_OK_Static_Expression (Index) then + Set_Do_Range_Check (Index); + end if; + end if; + + Next (Index); + end loop; + end if; + end Analyze_Array_Component_Update; + + ------------------------------------- + -- Analyze_Record_Component_Update -- + ------------------------------------- - -- Start of processing for Check_Component_Reference + procedure Analyze_Record_Component_Update (Comp : Node_Id) is + Comp_Name : constant Name_Id := Chars (Comp); + Base_Typ : Entity_Id; + Comp_Or_Discr : Entity_Id; begin -- Find the discriminant or component whose name corresponds to -- Comp. A simple character comparison is sufficient because all -- visible names within a record type are unique. - Comp_Or_Discr := First_Entity (Typ); + Comp_Or_Discr := First_Entity (P_Type); while Present (Comp_Or_Discr) loop if Chars (Comp_Or_Discr) = Comp_Name then - -- Record component entity and type in the given aggregate - -- choice, for subsequent resolution. + -- Decorate the component reference by setting its entity + -- and type for resolution purposes. Set_Entity (Comp, Comp_Or_Discr); Set_Etype (Comp, Etype (Comp_Or_Discr)); @@ -6234,7 +6283,7 @@ package body Sem_Attr is Comp_Or_Discr := Next_Entity (Comp_Or_Discr); end loop; - -- Diagnose possible illegal references + -- Diagnose an illegal reference if Present (Comp_Or_Discr) then if Ekind (Comp_Or_Discr) = E_Discriminant then @@ -6242,17 +6291,13 @@ package body Sem_Attr is ("attribute % may not modify record discriminants", Comp); else pragma Assert (Ekind (Comp_Or_Discr) = E_Component); - if Is_Duplicate_Component then - Error_Msg_NE ("component & already updated", Comp, Comp); + if Contains (Comps, Comp_Or_Discr) then + Error_Msg_N ("component & already updated", Comp); -- Mark this component as processed else - if No (Comps) then - Comps := New_Elmt_List; - end if; - - Append_Elmt (Comp, Comps); + Append_New_Elmt (Comp_Or_Discr, Comps); end if; end if; @@ -6260,22 +6305,39 @@ package body Sem_Attr is -- the record type. else - Error_Msg_NE - ("& is not a component of aggregate subtype", Comp, Comp); + Error_Msg_N ("& is not a component of aggregate subtype", Comp); + end if; + + -- Verify the consistency of types when the current component is + -- part of a miltiple component update. + + -- Comp_1, ..., Comp_N => + + if Present (Etype (Comp)) then + Base_Typ := Base_Type (Etype (Comp)); + + -- Save the type of the first component reference as the + -- remaning references (if any) must resolve to this type. + + if No (Common_Typ) then + Common_Typ := Base_Typ; + + elsif Base_Typ /= Common_Typ then + Error_Msg_N + ("components in choice list must have same type", Comp); + end if; end if; - end Check_Component_Reference; + end Analyze_Record_Component_Update; -- Local variables - Assoc : Node_Id; - Comp : Node_Id; - Comp_Type : Entity_Id; + Assoc : Node_Id; + Comp : Node_Id; -- Start of processing for Update begin Check_E1; - Check_Ada_2012_Attribute; if not Is_Object_Reference (P) then Error_Attr_P ("prefix of attribute % must denote an object"); @@ -6296,128 +6358,64 @@ package body Sem_Attr is -- choices. Perform the following checks: -- 1) Legality of "others" in all cases - -- 2) Component legality for records + -- 2) Legality of <> + -- 3) Component legality for arrays + -- 4) Component legality for records -- The remaining checks are performed on the expanded attribute Assoc := First (Component_Associations (E1)); while Present (Assoc) loop - Comp := First (Choices (Assoc)); - Analyze (Expression (Assoc)); - Comp_Type := Empty; - while Present (Comp) loop - if Nkind (Comp) = N_Others_Choice then - Error_Attr - ("others choice not allowed in attribute %", Comp); - elsif Is_Array_Type (P_Type) then - declare - Index : Node_Id; - Index_Type : Entity_Id; - Lo, Hi : Node_Id; + -- The use of <> is illegal (SPARK RM 4.4.1(1)) - begin - if Nkind (First (Choices (Assoc))) /= N_Aggregate then - - -- Choices denote separate components of one- - -- dimensional array. + if Box_Present (Assoc) then + Error_Attr + ("default initialization not allowed in attribute %", Assoc); - Index_Type := First_Index (P_Type); + -- Otherwise process the association - if Present (Next_Index (Index_Type)) then - Error_Msg_N - ("too few subscripts in array reference", Comp); - end if; + else + Analyze (Expression (Assoc)); - Index := First (Choices (Assoc)); - while Present (Index) loop - if Nkind (Index) = N_Range then - Lo := Low_Bound (Index); - Hi := High_Bound (Index); + if Is_Array_Type (P_Type) then + Analyze_Array_Component_Update (Assoc); - Analyze_And_Resolve (Lo, Etype (Index_Type)); + elsif Is_Record_Type (P_Type) then - if not Is_OK_Static_Expression (Lo) then - Set_Do_Range_Check (Lo); - end if; + -- Reset the common type used in a multiple component update + -- as we are processing the contents of a new association. - Analyze_And_Resolve (Hi, Etype (Index_Type)); + Common_Typ := Empty; - if not Is_OK_Static_Expression (Hi) then - Set_Do_Range_Check (Hi); - end if; + Comp := First (Choices (Assoc)); + while Present (Comp) loop + if Nkind (Comp) = N_Identifier then + Analyze_Record_Component_Update (Comp); - else - Analyze_And_Resolve (Index, Etype (Index_Type)); + -- The use of others is illegal (SPARK RM 4.4.1(5)) - if not Is_OK_Static_Expression (Index) then - Set_Do_Range_Check (Index); - end if; - end if; - - Next (Index); - end loop; + elsif Nkind (Comp) = N_Others_Choice then + Error_Attr + ("others choice not allowed in attribute %", Comp); - -- Choice is a sequence of indexes for each dimension + -- The name of a record component cannot appear in any + -- other form. else - Expr := First (Choices (Assoc)); - while Present (Expr) loop - Index_Type := First_Index (P_Type); - Index := First (Expressions (Expr)); - while Present (Index_Type) - and then Present (Index) - loop - Analyze_And_Resolve (Index, Etype (Index_Type)); - Next_Index (Index_Type); - Next (Index); - end loop; - - if Present (Index) or else Present (Index_Type) then - Error_Msg_N - ("dimension mismatch in index list", Assoc); - end if; - - Next (Expr); - end loop; - end if; - end; - - elsif Is_Record_Type (P_Type) then - - -- Make sure we have an identifier. Old SPARK allowed - -- a component selection e.g. A.B in the corresponding - -- context, but we do not yet permit this for 'Update. - - if Nkind (Comp) /= N_Identifier then - Error_Msg_N ("name should be identifier or OTHERS", Comp); - else - Check_Component_Reference (Comp, P_Type); - - -- Verify that all choices in an association denote - -- components of the same type. - - if No (Etype (Comp)) then - null; - - elsif No (Comp_Type) then - Comp_Type := Base_Type (Etype (Comp)); - - elsif Comp_Type /= Base_Type (Etype (Comp)) then Error_Msg_N - ("components in choice list must have same type", - Assoc); + ("name should be identifier or OTHERS", Comp); end if; - end if; - end if; - Next (Comp); - end loop; + Next (Comp); + end loop; + end if; + end if; Next (Assoc); end loop; - -- The type of attribute Update is that of the prefix + -- The type of attribute 'Update is that of the prefix Set_Etype (N, P_Type); end Update; @@ -6434,7 +6432,7 @@ package body Sem_Attr is if Is_Boolean_Type (P_Type) then Error_Msg_Name_1 := Aname; Error_Msg_Name_2 := Chars (P_Type); - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("attribute% is not allowed for type%", P); end if; @@ -6489,12 +6487,23 @@ package body Sem_Attr is when Attribute_Valid_Scalars => Check_E0; Check_Object_Reference (P); + Set_Etype (N, Standard_Boolean); - if No_Scalar_Parts (P_Type) then - Error_Attr_P ("??attribute % always True, no scalars to check"); - end if; + -- Following checks are only for source types - Set_Etype (N, Standard_Boolean); + if Comes_From_Source (N) then + if not Scalar_Part_Present (P_Type) then + Error_Attr_P + ("??attribute % always True, no scalars to check"); + end if; + + -- Not allowed for unchecked union type + + if Has_Unchecked_Union (P_Type) then + Error_Attr_P + ("attribute % not allowed for Unchecked_Union type"); + end if; + end if; ----------- -- Value -- @@ -6502,7 +6511,7 @@ package body Sem_Attr is when Attribute_Value => Value : begin - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -6581,7 +6590,7 @@ package body Sem_Attr is when Attribute_Wide_Image => Wide_Image : begin - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_Scalar_Type; Set_Etype (N, Standard_Wide_String); Check_E1; @@ -6624,7 +6633,7 @@ package body Sem_Attr is when Attribute_Wide_Value => Wide_Value : begin - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_E1; Check_Scalar_Type; @@ -6681,7 +6690,7 @@ package body Sem_Attr is ---------------- when Attribute_Wide_Width => - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); @@ -6691,7 +6700,7 @@ package body Sem_Attr is ----------- when Attribute_Width => - Check_SPARK_Restriction_On_Attribute; + Check_SPARK_05_Restriction_On_Attribute; Check_E0; Check_Scalar_Type; Set_Etype (N, Universal_Integer); @@ -6764,7 +6773,11 @@ package body Sem_Attr is Static : Boolean; -- True if the result is Static. This is set by the general processing -- to true if the prefix is static, and all expressions are static. It - -- can be reset as processing continues for particular attributes + -- can be reset as processing continues for particular attributes. This + -- flag can still be True if the reference raises a constraint error. + -- Is_Static_Expression (N) is set to follow this value as it is set + -- and we could always reference this, but it is convenient to have a + -- simple short name to use, since it is frequently referenced. Lo_Bound, Hi_Bound : Node_Id; -- Expressions for low and high bounds of type or array index referenced @@ -6803,9 +6816,6 @@ package body Sem_Attr is -- Computes the Fore value for the current attribute prefix, which is -- known to be a static fixed-point type. Used by Fore and Width. - function Is_VAX_Float (Typ : Entity_Id) return Boolean; - -- Determine whether Typ denotes a VAX floating point type - function Mantissa return Uint; -- Returns the Mantissa value for the prefix type @@ -6937,18 +6947,6 @@ package body Sem_Attr is return R; end Fore_Value; - ------------------ - -- Is_VAX_Float -- - ------------------ - - function Is_VAX_Float (Typ : Entity_Id) return Boolean is - begin - return - Is_Floating_Point_Type (Typ) - and then - (Float_Format = 'V' or else Float_Rep (Typ) = VAX_Native); - end Is_VAX_Float; - -------------- -- Mantissa -- -------------- @@ -7098,8 +7096,16 @@ package body Sem_Attr is Lo_Bound := Type_Low_Bound (Ityp); Hi_Bound := Type_High_Bound (Ityp); + -- If subtype is non-static, result is definitely non-static + if not Is_Static_Subtype (Ityp) then Static := False; + Set_Is_Static_Expression (N, False); + + -- Subtype is static, does it raise CE? + + elsif not Is_OK_Static_Subtype (Ityp) then + Set_Raises_Constraint_Error (N); end if; end Set_Bounds; @@ -7125,6 +7131,11 @@ package body Sem_Attr is -- Start of processing for Eval_Attribute begin + -- Initialize result as non-static, will be reset if appropriate + + Set_Is_Static_Expression (N, False); + Static := False; + -- Acquire first two expressions (at the moment, no attributes take more -- than two expressions in any case). @@ -7191,10 +7202,8 @@ package body Sem_Attr is -- the attribute to the type of the array, but we need a constrained -- type for this, so we use the actual subtype if available. - elsif Id = Attribute_First - or else - Id = Attribute_Last - or else + elsif Id = Attribute_First or else + Id = Attribute_Last or else Id = Attribute_Length then declare @@ -7234,7 +7243,7 @@ package body Sem_Attr is if Is_Entity_Name (P) and then Known_Alignment (Entity (P)) then - Fold_Uint (N, Alignment (Entity (P)), False); + Fold_Uint (N, Alignment (Entity (P)), Static); return; else @@ -7269,11 +7278,62 @@ package body Sem_Attr is P_Entity := Entity (P); end if; + -- If we are asked to evaluate an attribute where the prefix is a + -- non-frozen generic actual type whose RM_Size is still set to zero, + -- then abandon the effort. + + if Is_Type (P_Entity) + and then (not Is_Frozen (P_Entity) + and then Is_Generic_Actual_Type (P_Entity) + and then RM_Size (P_Entity) = 0) + + -- However, the attribute Unconstrained_Array must be evaluated, + -- since it is documented to be a static attribute (and can for + -- example appear in a Compile_Time_Warning pragma). The frozen + -- status of the type does not affect its evaluation. + + and then Id /= Attribute_Unconstrained_Array + then + return; + end if; + -- At this stage P_Entity is the entity to which the attribute -- is to be applied. This is usually simply the entity of the -- prefix, except in some cases of attributes for objects, where -- as described above, we apply the attribute to the object type. + -- Here is where we make sure that static attributes are properly + -- marked as such. These are attributes whose prefix is a static + -- scalar subtype, whose result is scalar, and whose arguments, if + -- present, are static scalar expressions. Note that such references + -- are static expressions even if they raise Constraint_Error. + + -- For example, Boolean'Pos (1/0 = 0) is a static expression, even + -- though evaluating it raises constraint error. This means that a + -- declaration like: + + -- X : constant := (if True then 1 else Boolean'Pos (1/0 = 0)); + + -- is legal, since here this expression appears in a statically + -- unevaluated position, so it does not actually raise an exception. + + if Is_Scalar_Type (P_Entity) + and then (not Is_Generic_Type (P_Entity)) + and then Is_Static_Subtype (P_Entity) + and then Is_Scalar_Type (Etype (N)) + and then + (No (E1) + or else (Is_Static_Expression (E1) + and then Is_Scalar_Type (Etype (E1)))) + and then + (No (E2) + or else (Is_Static_Expression (E2) + and then Is_Scalar_Type (Etype (E1)))) + then + Static := True; + Set_Is_Static_Expression (N, True); + end if; + -- First foldable possibility is a scalar or array type (RM 4.9(7)) -- that is not generic (generic types are eliminated by RM 4.9(25)). -- Note we allow non-static non-generic types at this stage as further @@ -7312,28 +7372,19 @@ package body Sem_Attr is end if; end if; - -- Definite must be folded if the prefix is not a generic type, - -- that is to say if we are within an instantiation. Same processing - -- applies to the GNAT attributes Atomic_Always_Lock_Free, - -- Has_Discriminants, Lock_Free, Type_Class, Has_Tagged_Value, and - -- Unconstrained_Array. + -- Definite must be folded if the prefix is not a generic type, that + -- is to say if we are within an instantiation. Same processing applies + -- to the GNAT attributes Atomic_Always_Lock_Free, Has_Discriminants, + -- Lock_Free, Type_Class, Has_Tagged_Value, and Unconstrained_Array. - elsif (Id = Attribute_Atomic_Always_Lock_Free - or else - Id = Attribute_Definite - or else - Id = Attribute_Has_Access_Values - or else - Id = Attribute_Has_Discriminants - or else - Id = Attribute_Has_Tagged_Values - or else - Id = Attribute_Lock_Free - or else - Id = Attribute_Type_Class - or else - Id = Attribute_Unconstrained_Array - or else + elsif (Id = Attribute_Atomic_Always_Lock_Free or else + Id = Attribute_Definite or else + Id = Attribute_Has_Access_Values or else + Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free or else + Id = Attribute_Type_Class or else + Id = Attribute_Unconstrained_Array or else Id = Attribute_Max_Alignment_For_Allocation) and then not Is_Generic_Type (P_Entity) then @@ -7427,7 +7478,12 @@ package body Sem_Attr is end if; if Is_Scalar_Type (P_Type) then - Static := Is_OK_Static_Subtype (P_Type); + if not Is_Static_Subtype (P_Type) then + Static := False; + Set_Is_Static_Expression (N, False); + elsif not Is_OK_Static_Subtype (P_Type) then + Set_Raises_Constraint_Error (N); + end if; -- Array case. We enforce the constrained requirement of (RM 4.9(7-8)) -- since we can't do anything with unconstrained arrays. In addition, @@ -7443,25 +7499,18 @@ package body Sem_Attr is -- unconstrained arrays. Furthermore, it is essential to fold this -- in the packed case, since otherwise the value will be incorrect. - elsif Id = Attribute_Atomic_Always_Lock_Free - or else - Id = Attribute_Definite - or else - Id = Attribute_Has_Access_Values - or else - Id = Attribute_Has_Discriminants - or else - Id = Attribute_Has_Tagged_Values - or else - Id = Attribute_Lock_Free - or else - Id = Attribute_Type_Class - or else - Id = Attribute_Unconstrained_Array - or else + elsif Id = Attribute_Atomic_Always_Lock_Free or else + Id = Attribute_Definite or else + Id = Attribute_Has_Access_Values or else + Id = Attribute_Has_Discriminants or else + Id = Attribute_Has_Tagged_Values or else + Id = Attribute_Lock_Free or else + Id = Attribute_Type_Class or else + Id = Attribute_Unconstrained_Array or else Id = Attribute_Component_Size then Static := False; + Set_Is_Static_Expression (N, False); elsif Id /= Attribute_Max_Alignment_For_Allocation then if not Is_Constrained (P_Type) @@ -7486,14 +7535,15 @@ package body Sem_Attr is -- which might otherwise accept non-static constants in contexts -- where they are not legal. - Static := Ada_Version >= Ada_95 - and then Statically_Denotes_Entity (P); + Static := + Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P); + Set_Is_Static_Expression (N, Static); declare - N : Node_Id; + Nod : Node_Id; begin - N := First_Index (P_Type); + Nod := First_Index (P_Type); -- The expression is static if the array type is constrained -- by given bounds, and not by an initial expression. Constant @@ -7502,21 +7552,28 @@ package body Sem_Attr is if Root_Type (P_Type) /= Standard_String then Static := Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); + Set_Is_Static_Expression (N, Static); + end if; - while Present (N) loop - Static := Static and then Is_Static_Subtype (Etype (N)); + while Present (Nod) loop + if not Is_Static_Subtype (Etype (Nod)) then + Static := False; + Set_Is_Static_Expression (N, False); + elsif not Is_OK_Static_Subtype (Etype (Nod)) then + Set_Raises_Constraint_Error (N); + end if; -- If however the index type is generic, or derived from -- one, attributes cannot be folded. - if Is_Generic_Type (Root_Type (Etype (N))) + if Is_Generic_Type (Root_Type (Etype (Nod))) and then Id /= Attribute_Component_Size then return; end if; - Next_Index (N); + Next_Index (Nod); end loop; end; end if; @@ -7541,6 +7598,11 @@ package body Sem_Attr is if not Is_Static_Expression (E) then Static := False; + Set_Is_Static_Expression (N, False); + end if; + + if Raises_Constraint_Error (E) then + Set_Raises_Constraint_Error (N); end if; -- If the result is not known at compile time, or is not of @@ -7601,7 +7663,7 @@ package body Sem_Attr is Set_Raises_Constraint_Error (CE_Node); Check_Expressions; Rewrite (N, Relocate_Node (CE_Node)); - Set_Is_Static_Expression (N, Static); + Set_Raises_Constraint_Error (N, True); return; end if; @@ -7658,7 +7720,7 @@ package body Sem_Attr is --------- when Attribute_Aft => - Fold_Uint (N, Aft_Value (P_Type), True); + Fold_Uint (N, Aft_Value (P_Type), Static); --------------- -- Alignment -- @@ -7671,24 +7733,10 @@ package body Sem_Attr is -- Fold if alignment is set and not otherwise if Known_Alignment (P_TypeA) then - Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA)); + Fold_Uint (N, Alignment (P_TypeA), Static); end if; end Alignment_Block; - --------------- - -- AST_Entry -- - --------------- - - -- Can only be folded in No_Ast_Handler case - - when Attribute_AST_Entry => - if not Is_AST_Entry (P_Entity) then - Rewrite (N, - New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc)); - else - null; - end if; - ----------------------------- -- Atomic_Always_Lock_Free -- ----------------------------- @@ -7710,7 +7758,8 @@ package body Sem_Attr is -- static attribute in GNAT. Analyze_And_Resolve (N, Standard_Boolean); - Static := True; + Static := True; + Set_Is_Static_Expression (N, True); end Atomic_Always_Lock_Free; --------- @@ -7745,7 +7794,7 @@ package body Sem_Attr is when Attribute_Component_Size => if Known_Static_Component_Size (P_Type) then - Fold_Uint (N, Component_Size (P_Type), False); + Fold_Uint (N, Component_Size (P_Type), Static); end if; ------------- @@ -7766,6 +7815,12 @@ package body Sem_Attr is -- could be handled at compile time. To be looked at later. when Attribute_Constrained => + + -- The expander might fold it and set the static flag accordingly, + -- but with expansion disabled (as in ASIS), it remains as an + -- attribute reference, and this reference is not static. + + Set_Is_Static_Expression (N, False); null; --------------- @@ -7801,7 +7856,7 @@ package body Sem_Attr is when Attribute_Denorm => Fold_Uint - (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), True); + (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), Static); --------------------- -- Descriptor_Size -- @@ -7815,7 +7870,7 @@ package body Sem_Attr is ------------ when Attribute_Digits => - Fold_Uint (N, Digits_Value (P_Type), True); + Fold_Uint (N, Digits_Value (P_Type), Static); ---------- -- Emax -- @@ -7827,7 +7882,7 @@ package body Sem_Attr is -- T'Emax = 4 * T'Mantissa - Fold_Uint (N, 4 * Mantissa, True); + Fold_Uint (N, 4 * Mantissa, Static); -------------- -- Enum_Rep -- @@ -7920,16 +7975,6 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (Lo_Bound), Static); end if; - -- Replace VAX Float_Type'First with a reference to the temporary - -- which represents the low bound of the type. This transformation - -- is needed since the back end cannot evaluate 'First on VAX. - - elsif Is_VAX_Float (P_Type) - and then Nkind (Lo_Bound) = N_Identifier - then - Rewrite (N, New_Occurrence_Of (Entity (Lo_Bound), Sloc (N))); - Analyze (N); - else Check_Concurrent_Discriminant (Lo_Bound); end if; @@ -7942,10 +7987,11 @@ package body Sem_Attr is when Attribute_First_Valid => First_Valid : begin if Has_Predicates (P_Type) - and then Present (Static_Predicate (P_Type)) + and then Has_Static_Predicate (P_Type) then declare - FirstN : constant Node_Id := First (Static_Predicate (P_Type)); + FirstN : constant Node_Id := + First (Static_Discrete_Predicate (P_Type)); begin if Nkind (FirstN) = N_Range then Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static); @@ -8153,7 +8199,8 @@ package body Sem_Attr is -- static attribute in GNAT. Analyze_And_Resolve (N, Standard_Boolean); - Static := True; + Static := True; + Set_Is_Static_Expression (N, True); end Lock_Free; ---------- @@ -8171,16 +8218,6 @@ package body Sem_Attr is Fold_Uint (N, Expr_Value (Hi_Bound), Static); end if; - -- Replace VAX Float_Type'Last with a reference to the temporary - -- which represents the high bound of the type. This transformation - -- is needed since the back end cannot evaluate 'Last on VAX. - - elsif Is_VAX_Float (P_Type) - and then Nkind (Hi_Bound) = N_Identifier - then - Rewrite (N, New_Occurrence_Of (Entity (Hi_Bound), Sloc (N))); - Analyze (N); - else Check_Concurrent_Discriminant (Hi_Bound); end if; @@ -8193,10 +8230,11 @@ package body Sem_Attr is when Attribute_Last_Valid => Last_Valid : begin if Has_Predicates (P_Type) - and then Present (Static_Predicate (P_Type)) + and then Has_Static_Predicate (P_Type) then declare - LastN : constant Node_Id := Last (Static_Predicate (P_Type)); + LastN : constant Node_Id := + Last (Static_Discrete_Predicate (P_Type)); begin if Nkind (LastN) = N_Range then Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static); @@ -8252,7 +8290,7 @@ package body Sem_Attr is then Fold_Uint (N, UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))), - True); + Static); end if; -- One more case is where Hi_Bound and Lo_Bound are compile-time @@ -8267,14 +8305,14 @@ package body Sem_Attr is (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) is when EQ => - Fold_Uint (N, Uint_1, False); + Fold_Uint (N, Uint_1, Static); when GT => - Fold_Uint (N, Uint_0, False); + Fold_Uint (N, Uint_0, Static); when LT => if Diff /= No_Uint then - Fold_Uint (N, Diff + 1, False); + Fold_Uint (N, Diff + 1, Static); end if; when others => @@ -8336,14 +8374,14 @@ package body Sem_Attr is -- Always true for fixed-point if Is_Fixed_Point_Type (P_Type) then - Fold_Uint (N, True_Value, True); + Fold_Uint (N, True_Value, Static); -- Floating point case else Fold_Uint (N, UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)), - True); + Static); end if; ------------------- @@ -8355,15 +8393,15 @@ package body Sem_Attr is if Is_Decimal_Fixed_Point_Type (P_Type) and then Machine_Radix_10 (P_Type) then - Fold_Uint (N, Uint_10, True); + Fold_Uint (N, Uint_10, Static); else - Fold_Uint (N, Uint_2, True); + Fold_Uint (N, Uint_2, Static); end if; -- All floating-point type always have radix 2 else - Fold_Uint (N, Uint_2, True); + Fold_Uint (N, Uint_2, Static); end if; ---------------------- @@ -8389,13 +8427,14 @@ package body Sem_Attr is -- Always False for fixed-point if Is_Fixed_Point_Type (P_Type) then - Fold_Uint (N, False_Value, True); + Fold_Uint (N, False_Value, Static); -- Else yield proper floating-point result else Fold_Uint - (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True); + (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), + Static); end if; ------------------ @@ -8409,7 +8448,7 @@ package body Sem_Attr is begin if Known_Esize (P_TypeA) then - Fold_Uint (N, Esize (P_TypeA), True); + Fold_Uint (N, Esize (P_TypeA), Static); end if; end Machine_Size; @@ -8482,7 +8521,7 @@ package body Sem_Attr is Siz := Siz + 1; end loop; - Fold_Uint (N, Siz, True); + Fold_Uint (N, Siz, Static); end; else @@ -8495,7 +8534,7 @@ package body Sem_Attr is -- Floating-point Mantissa else - Fold_Uint (N, Mantissa, True); + Fold_Uint (N, Mantissa, Static); end if; --------- @@ -8576,7 +8615,7 @@ package body Sem_Attr is end if; if Mech < 0 then - Fold_Uint (N, UI_From_Int (Int (-Mech)), True); + Fold_Uint (N, UI_From_Int (Int (-Mech)), Static); end if; end; @@ -8644,7 +8683,7 @@ package body Sem_Attr is ------------- when Attribute_Modulus => - Fold_Uint (N, Modulus (P_Type), True); + Fold_Uint (N, Modulus (P_Type), Static); -------------------- -- Null_Parameter -- @@ -8669,7 +8708,7 @@ package body Sem_Attr is begin if Known_Esize (P_TypeA) then - Fold_Uint (N, Esize (P_TypeA), True); + Fold_Uint (N, Esize (P_TypeA), Static); end if; end Object_Size; @@ -8687,14 +8726,14 @@ package body Sem_Attr is -- Scalar types are never passed by reference when Attribute_Passed_By_Reference => - Fold_Uint (N, False_Value, True); + Fold_Uint (N, False_Value, Static); --------- -- Pos -- --------- when Attribute_Pos => - Fold_Uint (N, Expr_Value (E1), True); + Fold_Uint (N, Expr_Value (E1), Static); ---------- -- Pred -- @@ -8782,14 +8821,14 @@ package body Sem_Attr is (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False) is when EQ => - Fold_Uint (N, Uint_1, False); + Fold_Uint (N, Uint_1, Static); when GT => - Fold_Uint (N, Uint_0, False); + Fold_Uint (N, Uint_0, Static); when LT => if Diff /= No_Uint then - Fold_Uint (N, Diff + 1, False); + Fold_Uint (N, Diff + 1, Static); end if; when others => @@ -8802,7 +8841,7 @@ package body Sem_Attr is --------- when Attribute_Ref => - Fold_Uint (N, Expr_Value (E1), True); + Fold_Uint (N, Expr_Value (E1), Static); --------------- -- Remainder -- @@ -8924,7 +8963,7 @@ package body Sem_Attr is ----------- when Attribute_Scale => - Fold_Uint (N, Scale_Value (P_Type), True); + Fold_Uint (N, Scale_Value (P_Type), Static); ------------- -- Scaling -- @@ -8951,13 +8990,15 @@ package body Sem_Attr is -- Size attribute returns the RM size. All scalar types can be folded, -- as well as any types for which the size is known by the front end, - -- including any type for which a size attribute is specified. + -- including any type for which a size attribute is specified. This 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); begin - if RM_Size (P_TypeA) /= Uint_0 then + if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then -- VADS_Size case @@ -8982,23 +9023,21 @@ package body Sem_Attr is if Present (S) and then Is_OK_Static_Expression (Expression (S)) then - Fold_Uint (N, Expr_Value (Expression (S)), True); + 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). else - Fold_Uint (N, Esize (P_TypeA), True); + Fold_Uint (N, Esize (P_TypeA), Static); end if; end; -- Normal case (Size) in which case we want the RM_Size else - Fold_Uint (N, - RM_Size (P_TypeA), - Static and then Is_Discrete_Type (P_TypeA)); + Fold_Uint (N, RM_Size (P_TypeA), Static); end if; end if; end Size; @@ -9179,6 +9218,7 @@ package body Sem_Attr is Analyze_And_Resolve (N, Standard_Boolean); Static := True; + Set_Is_Static_Expression (N, True); end Unconstrained_Array; -- Attribute Update is never static @@ -9219,15 +9259,16 @@ package body Sem_Attr is -- Value_Size -- ---------------- - -- The Value_Size attribute for a type returns the RM size of the - -- type. This an always be folded for scalar types, and can also - -- be folded for non-scalar types if the size is set. + -- The Value_Size attribute for a type returns the RM size of the type. + -- This an always be folded for scalar types, and can also be folded for + -- non-scalar types if the size is set. This is one of the places where + -- it is annoying that a size of zero means two things! when Attribute_Value_Size => Value_Size : declare P_TypeA : constant Entity_Id := Underlying_Type (P_Type); begin - if RM_Size (P_TypeA) /= Uint_0 then - Fold_Uint (N, RM_Size (P_TypeA), True); + if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then + Fold_Uint (N, RM_Size (P_TypeA), Static); end if; end Value_Size; @@ -9293,7 +9334,7 @@ package body Sem_Attr is if Expr_Value_R (Type_High_Bound (P_Type)) < Expr_Value_R (Type_Low_Bound (P_Type)) then - Fold_Uint (N, Uint_0, True); + Fold_Uint (N, Uint_0, Static); else -- For floating-point, we have +N.dddE+nnn where length @@ -9318,7 +9359,7 @@ package body Sem_Attr is Len := Len + 8; end if; - Fold_Uint (N, UI_From_Int (Len), True); + Fold_Uint (N, UI_From_Int (Len), Static); end; end if; @@ -9331,7 +9372,7 @@ package body Sem_Attr is if Expr_Value (Type_High_Bound (P_Type)) < Expr_Value (Type_Low_Bound (P_Type)) then - Fold_Uint (N, Uint_0, True); + Fold_Uint (N, Uint_0, Static); -- The non-null case depends on the specific real type @@ -9340,7 +9381,7 @@ package body Sem_Attr is Fold_Uint (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type), - True); + Static); end if; -- Discrete types @@ -9517,7 +9558,7 @@ package body Sem_Attr is end loop; end if; - Fold_Uint (N, UI_From_Int (W), True); + Fold_Uint (N, UI_From_Int (W), Static); end; end if; end if; @@ -9535,66 +9576,67 @@ package body Sem_Attr is -- Note that in some cases, the values have already been folded as -- a result of the processing in Analyze_Attribute. - 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_Elaborated | - Attribute_Elab_Body | - Attribute_Elab_Spec | - Attribute_Elab_Subp_Body | - Attribute_Enabled | - Attribute_External_Tag | - Attribute_Fast_Math | - Attribute_First_Bit | - 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_UET_Address | - 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_Elaborated | + Attribute_Elab_Body | + Attribute_Elab_Spec | + Attribute_Elab_Subp_Body | + Attribute_Enabled | + Attribute_External_Tag | + Attribute_Fast_Math | + Attribute_First_Bit | + 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_UET_Address | + 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; @@ -9637,8 +9679,7 @@ package body Sem_Attr is function Is_Anonymous_Tagged_Base (Anon : Entity_Id; - Typ : Entity_Id) - return Boolean + Typ : Entity_Id) return Boolean is begin return @@ -10441,6 +10482,91 @@ package body Sem_Attr is if Is_Entity_Name (P) then Set_Address_Taken (Entity (P)); end if; + + -- Deal with possible elaboration check + + if Is_Entity_Name (P) and then Is_Subprogram (Entity (P)) then + declare + Subp_Id : constant Entity_Id := Entity (P); + Scop : constant Entity_Id := Scope (Subp_Id); + Subp_Decl : constant Node_Id := + Unit_Declaration_Node (Subp_Id); + + Flag_Id : Entity_Id; + HSS : Node_Id; + Stmt : Node_Id; + + -- If the access has been taken and the body of the subprogram + -- has not been see yet, indirect calls must be protected with + -- elaboration checks. We have the proper elaboration machinery + -- for subprograms declared in packages, but within a block or + -- a subprogram the body will appear in the same declarative + -- part, and we must insert a check in the eventual body itself + -- using the elaboration flag that we generate now. The check + -- is then inserted when the body is expanded. This processing + -- is not needed for a stand alone expression function because + -- the internally generated spec and body are always inserted + -- as a pair in the same declarative list. + + begin + if Expander_Active + and then Comes_From_Source (Subp_Id) + and then Comes_From_Source (N) + and then In_Open_Scopes (Scop) + and then Ekind_In (Scop, E_Block, E_Procedure, E_Function) + and then not Has_Completion (Subp_Id) + and then No (Elaboration_Entity (Subp_Id)) + and then Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Nkind (Original_Node (Subp_Decl)) /= + N_Expression_Function + then + -- Create elaboration variable for it + + Flag_Id := Make_Temporary (Loc, 'E'); + Set_Elaboration_Entity (Subp_Id, Flag_Id); + Set_Is_Frozen (Flag_Id); + + -- Insert declaration for flag after subprogram + -- declaration. Note that attribute reference may + -- appear within a nested scope. + + Insert_After_And_Analyze (Subp_Decl, + Make_Object_Declaration (Loc, + Defining_Identifier => Flag_Id, + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loc), + Expression => + Make_Integer_Literal (Loc, Uint_0))); + end if; + + -- Taking the 'Access of an expression function freezes its + -- expression (RM 13.14 10.3/3). This does not apply to an + -- expression function that acts as a completion because the + -- generated body is immediately analyzed and the expression + -- is automatically frozen. + + if Ekind (Subp_Id) = E_Function + and then Nkind (Subp_Decl) = N_Subprogram_Declaration + and then Nkind (Original_Node (Subp_Decl)) = + N_Expression_Function + and then Present (Corresponding_Body (Subp_Decl)) + and then not Analyzed (Corresponding_Body (Subp_Decl)) + then + HSS := + Handled_Statement_Sequence + (Unit_Declaration_Node + (Corresponding_Body (Subp_Decl))); + + if Present (HSS) then + Stmt := First (Statements (HSS)); + + if Nkind (Stmt) = N_Simple_Return_Statement then + Freeze_Expression (Expression (Stmt)); + end if; + end if; + end if; + end; + end if; end Access_Attribute; ------------- @@ -10563,16 +10689,6 @@ package body Sem_Attr is end if; end Address_Attribute; - --------------- - -- AST_Entry -- - --------------- - - -- Prefix of the AST_Entry attribute is an entry name which must - -- not be resolved, since this is definitely not an entry call. - - when Attribute_AST_Entry => - null; - ------------------ -- Body_Version -- ------------------ @@ -10834,9 +10950,27 @@ package body Sem_Attr is if Is_Array_Type (Typ) then Assoc := First (Component_Associations (Aggr)); while Present (Assoc) loop - Expr := Expression (Assoc); + Expr := Expression (Assoc); Resolve (Expr, Component_Type (Typ)); - Aggregate_Constraint_Checks (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 + null; + + 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 @@ -10901,10 +11035,6 @@ package body Sem_Attr is end if; end; - -- Premature return requires comment ??? - - return; - --------- -- Val -- --------- @@ -11016,15 +11146,12 @@ package body Sem_Attr is procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is Loc : constant Source_Ptr := Sloc (N); - begin if B then Rewrite (N, New_Occurrence_Of (Standard_True, Loc)); else Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); end if; - - Set_Is_Static_Expression (N); end Set_Boolean_Result; -------------------------------- diff --git a/main/gcc/ada/sem_attr.ads b/main/gcc/ada/sem_attr.ads index 7583ab434f4..c2652211b21 100644 --- a/main/gcc/ada/sem_attr.ads +++ b/main/gcc/ada/sem_attr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -89,23 +89,6 @@ package Sem_Attr is -- Machine_Code to construct machine instructions. See documentation -- in package Machine_Code in file s-maccod.ads. - --------------- - -- AST_Entry -- - --------------- - - Attribute_AST_Entry => True, - -- E'Ast_Entry, where E is a task entry, yields a value of the - -- predefined type System.DEC.AST_Handler, that enables the given - -- entry to be called when an AST occurs. If the name to which the - -- attribute applies has not been specified with the pragma AST_Entry, - -- the attribute returns the value No_Ast_Handler, and no AST occurs. - -- If the entry is for a task that is not callable (T'Callable False), - -- the exception program error is raised. If an AST occurs for an - -- entry of a task that is terminated, the program is erroneous. - -- - -- The attribute AST_Entry is supported only in OpenVMS versions - -- of GNAT. It will be rejected as illegal in other GNAT versions. - --------- -- Bit -- --------- @@ -152,20 +135,31 @@ package Sem_Attr is ----------------------- Attribute_Default_Bit_Order => True, - -- Standard'Default_Bit_Order (Standard is the only permissible prefix), + -- Standard'Default_Bit_Order (Standard is the only permissible prefix) -- provides the value System.Default_Bit_Order as a Pos value (0 for -- High_Order_First, 1 for Low_Order_First). This is used to construct -- the definition of Default_Bit_Order in package System. This is a -- static attribute. + ---------------------------------- + -- Default_Scalar_Storage_Order -- + ---------------------------------- + + Attribute_Default_Scalar_Storage_Order => True, + -- Standard'Default_Scalar_Storage_Order (Standard is the + -- only permissible prefix) provides the current value of the + -- default scalar storage order (as specified using pragma + -- Default_Scalar_Storage_Order, or equal to Default_Bit_Order if + -- unspecified) as a System.Bit_Order value. This is a static attribute. + --------------- -- Elab_Body -- --------------- Attribute_Elab_Body => True, - -- This attribute can only be applied to a program unit name. It returns - -- the entity for the corresponding elaboration procedure for elabor- - -- ating the body of the referenced unit. This is used in the main + -- This attribute can only be applied to a program unit name. It + -- returns the entity for the corresponding elaboration procedure for + -- elaborating the body of the referenced unit. This is used in the main -- generated elaboration procedure by the binder, and is not normally -- used in any other context, but there may be specialized situations in -- which it is useful to be able to call this elaboration procedure from @@ -189,13 +183,13 @@ package Sem_Attr is Attribute_Elab_Spec => True, -- This attribute can only be applied to a program unit name. It - -- returns the entity for the corresponding elaboration procedure - -- for elaborating the spec of the referenced unit. This is used - -- in the main generated elaboration procedure by the binder, and - -- is not normally used in any other context, but there may be - -- specialized situations in which it is useful to be able to - -- call this elaboration procedure from Ada code, e.g. if it - -- is necessary to do selective reelaboration to fix some error. + -- returns the entity for the corresponding elaboration procedure for + -- elaborating the spec of the referenced unit. This is used in the main + -- generated elaboration procedure by the binder, and is not normally + -- used in any other context, but there may be specialized situations in + -- which it is useful to be able to call this elaboration procedure from + -- Ada code, e.g. if it is necessary to do selective reelaboration to + -- fix some error. ---------------- -- Elaborated -- @@ -226,8 +220,8 @@ package Sem_Attr is -------------- Attribute_Enum_Val => True, - -- For every enumeration subtype S, S'Enum_Val denotes a function - -- with the following specification: + -- For every enumeration subtype S, S'Enum_Val denotes a function with + -- the following specification: -- -- function S'Enum_Val (Arg : universal_integer) return S'Base; -- @@ -253,8 +247,8 @@ package Sem_Attr is -- The effect is thus equivalent to first converting the argument to -- the integer type used to represent S, and then doing an unchecked -- conversion to the fixed-point type. This attribute is primarily - -- intended for use in implementation of the input-output functions for - -- fixed-point values. + -- intended for use in implementation of the input-output functions + -- for fixed-point values. ----------------------- -- Has_Discriminants -- @@ -307,10 +301,10 @@ package Sem_Attr is -- of the type. If possible this value is an invalid value, and in fact -- is identical to the value that would be set if Initialize_Scalars -- mode were in effect (including the behavior of its value on - -- environment variables or binder switches). The intended use is - -- to set a value where initialization is required (e.g. as a result of - -- the coding standards in use), but logically no initialization is - -- needed, and the value should never be accessed. + -- environment variables or binder switches). The intended use is to + -- set a value where initialization is required (e.g. as a result of the + -- coding standards in use), but logically no initialization is needed, + -- and the value should never be accessed. Attribute_Loop_Entry => True, -- For every object of a non-limited type, S'Loop_Entry [(Loop_Name)] @@ -331,11 +325,11 @@ package Sem_Attr is Attribute_Maximum_Alignment => True, -- Standard'Maximum_Alignment (Standard is the only permissible prefix) - -- provides the maximum useful alignment value for the target. This - -- is a static value that can be used to specify the alignment for an - -- object, guaranteeing that it is properly aligned in all cases. The - -- time this is useful is when an external object is imported and its - -- alignment requirements are unknown. This is a static attribute. + -- provides the maximum useful alignment value for the target. This is a + -- static value that can be used to specify the alignment for an object, + -- guaranteeing that it is properly aligned in all cases. The time this + -- is useful is when an external object is imported and its alignment + -- requirements are unknown. This is a static attribute. -------------------- -- Mechanism_Code -- @@ -363,19 +357,19 @@ package Sem_Attr is -------------------- Attribute_Null_Parameter => True, - -- A reference T'Null_Parameter denotes an (imaginary) object of type or - -- subtype T allocated at (machine) address zero. The attribute is - -- allowed only as the default expression of a formal parameter, or as - -- an actual expression of a subprogram call. In either case, the + -- A reference T'Null_Parameter denotes an (imaginary) object of type + -- or subtype T allocated at (machine) address zero. The attribute is + -- allowed only as the default expression of a formal parameter, or + -- as an actual expression of a subprogram call. In either case, the -- subprogram must be imported. -- - -- The identity of the object is represented by the address zero in the - -- argument list, independent of the passing mechanism (explicit or - -- default). + -- The identity of the object is represented by the address zero in + -- the argument list, independent of the passing mechanism (explicit + -- or default). -- -- The reason that this capability is needed is that for a record or - -- other composite object passed by reference, there is no other way of - -- specifying that a zero address should be passed. + -- other composite object passed by reference, there is no other way + -- of specifying that a zero address should be passed. ----------------- -- Object_Size -- diff --git a/main/gcc/ada/sem_aux.adb b/main/gcc/ada/sem_aux.adb index 0344637dccc..4b251e31c51 100644 --- a/main/gcc/ada/sem_aux.adb +++ b/main/gcc/ada/sem_aux.adb @@ -439,45 +439,45 @@ package body Sem_Aux is --------------------- function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is - Name : constant String := Get_Name_String (Chars (Op)); begin - if Name = "Oadd" then - return N_Op_Add; - elsif Name = "Oconcat" then - return N_Op_Concat; - elsif Name = "Oexpon" then - return N_Op_Expon; - elsif Name = "Osubtract" then - return N_Op_Subtract; - elsif Name = "Omod" then - return N_Op_Mod; - elsif Name = "Omultiply" then - return N_Op_Multiply; - elsif Name = "Odivide" then - return N_Op_Divide; - elsif Name = "Orem" then - return N_Op_Rem; - elsif Name = "Oand" then - return N_Op_And; - elsif Name = "Oeq" then - return N_Op_Eq; - elsif Name = "Oge" then - return N_Op_Ge; - elsif Name = "Ogt" then - return N_Op_Gt; - elsif Name = "Ole" then - return N_Op_Le; - elsif Name = "Olt" then - return N_Op_Lt; - elsif Name = "One" then - return N_Op_Ne; - elsif Name = "Oxor" then - return N_Op_Or; - elsif Name = "Oor" then - return N_Op_Xor; - else - raise Program_Error; - end if; + 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; + end case; end Get_Binary_Nkind; ------------------ @@ -652,19 +652,19 @@ package body Sem_Aux is --------------------- function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is - Name : constant String := Get_Name_String (Chars (Op)); begin - if Name = "Oabs" then - return N_Op_Abs; - elsif Name = "Osubtract" then - return N_Op_Minus; - elsif Name = "Onot" then - return N_Op_Not; - elsif Name = "Oadd" then - return N_Op_Plus; - else - raise Program_Error; - end if; + 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; + end case; end Get_Unary_Nkind; --------------------------------- diff --git a/main/gcc/ada/sem_aux.ads b/main/gcc/ada/sem_aux.ads index 4eaf1bfb3ce..bb539e2e17a 100644 --- a/main/gcc/ada/sem_aux.ads +++ b/main/gcc/ada/sem_aux.ads @@ -131,7 +131,7 @@ package Sem_Aux is -- stored discriminants are the same as the actual discriminants of the -- type, and hence this function is the same as First_Discriminant. -- - -- For derived non-tagged types that rename discriminants in the root type + -- For derived untagged types that rename discriminants in the root type -- this is the first of the discriminants that occur in the root type. To -- be precise, in this case stored discriminants are entities attached to -- the entity chain of the derived type which are a copy of the @@ -152,6 +152,18 @@ package Sem_Aux is -- Typ must be a tagged record type. This function returns the Entity for -- the first _Tag field in the record type. + function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind; + -- Op must be an entity with an Ekind of E_Operator. This function returns + -- the Nkind value that would be used to construct a binary operator node + -- referencing this entity. It is an error to call this function if Ekind + -- (Op) /= E_Operator. + + function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind; + -- Op must be an entity with an Ekind of E_Operator. This function returns + -- the Nkind value that would be used to construct a unary operator node + -- referencing this entity. It is an error to call this function if Ekind + -- (Op) /= E_Operator. + function Get_Rep_Item (E : Entity_Id; Nam : Name_Id; @@ -386,17 +398,4 @@ package Sem_Aux is -- package specification. Simplifies handling of child units, and better -- than the old idiom: Specification (Unit_Declaration_Node (Pack_Id)). - function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind; - -- Op must be an entity with an Ekind of E_Operator. - -- This function returns the Nkind value that would - -- be used to construct a binary operator node referencing - -- this entity. It is an error to call this function - -- if Ekind (Op) /= E_Operator. - - function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind; - -- Op must be an entity with an Ekind of E_Operator. - -- This function returns the Nkind value that would - -- be used to construct a unary operator node referencing - -- this entity. It is an error to call this function - -- if Ekind (Op) /= E_Operator. end Sem_Aux; diff --git a/main/gcc/ada/sem_case.adb b/main/gcc/ada/sem_case.adb index fc7dc44ef96..201855b5e36 100644 --- a/main/gcc/ada/sem_case.adb +++ b/main/gcc/ada/sem_case.adb @@ -114,6 +114,10 @@ package body Sem_Case is Others_Present : Boolean; Case_Node : Node_Id) is + Predicate_Error : Boolean; + -- Flag to prevent cascaded errors when a static predicate is known to + -- be violated by one choice. + procedure Check_Against_Predicate (Pred : in out Node_Id; Choice : Choice_Bounds; @@ -433,9 +437,10 @@ package body Sem_Case is Error := True; -- The previous choice covered part of the static predicate set + -- but there is a gap after Prev_Hi. else - Missing_Choice (Prev_Hi, Choice_Lo - 1); + Missing_Choice (Prev_Hi + 1, Choice_Lo - 1); Error := True; end if; end if; @@ -455,12 +460,33 @@ package body Sem_Case is return; end if; - -- Case of only one value that is missing + -- Case of only one value that is duplicated if Lo = Hi then + + -- Integer type + if Is_Integer_Type (Bounds_Type) then - Error_Msg_Uint_1 := Lo; - Error_Msg_N ("duplication of choice value: ^#!", C); + + -- We have an integer value, Lo, but if the given choice + -- placement is a constant with that value, then use the + -- name of that constant instead in the message: + + if Nkind (C) = N_Identifier + and then Compile_Time_Known_Value (C) + and then Expr_Value (C) = Lo + then + Error_Msg_N ("duplication of choice value: &#!", C); + + -- Not that special case, so just output the integer value + + else + Error_Msg_Uint_1 := Lo; + Error_Msg_N ("duplication of choice value: ^#!", C); + end if; + + -- Enumeration type + else Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); Error_Msg_N ("duplication of choice value: %#!", C); @@ -469,10 +495,38 @@ package body Sem_Case is -- More than one choice value, so print range of values else + -- Integer type + if Is_Integer_Type (Bounds_Type) then - Error_Msg_Uint_1 := Lo; - Error_Msg_Uint_2 := Hi; - Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); + + -- Similar to the above, if C is a range of known values which + -- match Lo and Hi, then use the names. We have to go to the + -- original nodes, since the values will have been rewritten + -- to their integer values. + + if Nkind (C) = N_Range + and then Nkind (Original_Node (Low_Bound (C))) = N_Identifier + and then Nkind (Original_Node (High_Bound (C))) = N_Identifier + and then Compile_Time_Known_Value (Low_Bound (C)) + and then Compile_Time_Known_Value (High_Bound (C)) + and then Expr_Value (Low_Bound (C)) = Lo + and then Expr_Value (High_Bound (C)) = Hi + then + Error_Msg_Node_2 := Original_Node (High_Bound (C)); + Error_Msg_N + ("duplication of choice values: & .. &#!", + Original_Node (Low_Bound (C))); + + -- Not that special case, output integer values + + else + Error_Msg_Uint_1 := Lo; + Error_Msg_Uint_2 := Hi; + Error_Msg_N ("duplication of choice values: ^ .. ^#!", C); + end if; + + -- Enumeration type + else Error_Msg_Name_1 := Choice_Image (Lo, Bounds_Type); Error_Msg_Name_2 := Choice_Image (Hi, Bounds_Type); @@ -561,6 +615,10 @@ package body Sem_Case is Missing_Choice (Value1, Expr_Value (Value2)); end Missing_Choice; + -------------------- + -- Missing_Choice -- + -------------------- + procedure Missing_Choice (Value1 : Uint; Value2 : Uint) is Msg_Sloc : constant Source_Ptr := Sloc (Case_Node); @@ -576,6 +634,12 @@ package body Sem_Case is elsif Value1 > Value2 then return; + + -- If predicate is already known to be violated, do no check for + -- coverage error, to prevent cascaded messages. + + elsif Predicate_Error then + return; end if; -- Case of only one value that is missing @@ -647,8 +711,8 @@ package body Sem_Case is Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type); Num_Choices : constant Nat := Choice_Table'Last; Has_Predicate : constant Boolean := - Is_Static_Subtype (Bounds_Type) - and then Present (Static_Predicate (Bounds_Type)); + Is_OK_Static_Subtype (Bounds_Type) + and then Has_Static_Predicate (Bounds_Type); Choice : Node_Id; Choice_Hi : Uint; @@ -671,6 +735,8 @@ 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. @@ -696,13 +762,10 @@ package body Sem_Case is -- Note that in GNAT the predicate is considered static if the predicate -- expression is static, independently of whether the aspect mentions - -- Static explicitly. It is unclear whether this is RM-conforming, but - -- it's certainly useful, and GNAT source make use of this. The downside - -- is that currently case expressions cannot appear in predicates that - -- are not static. ??? + -- Static explicitly. if Has_Predicate then - Pred := First (Static_Predicate (Bounds_Type)); + Pred := First (Static_Discrete_Predicate (Bounds_Type)); Prev_Lo := Uint_Minus_1; Prev_Hi := Uint_Minus_1; Error := False; @@ -716,13 +779,22 @@ package body Sem_Case is Error => Error); -- The analysis detected an illegal intersection between a choice - -- and a static predicate set. + -- and a static predicate set. Do not examine other choices unless + -- all errors are requested. if Error then - return; + Predicate_Error := True; + + if not All_Errors_Mode then + return; + end if; end if; end loop; + if Predicate_Error then + return; + end if; + -- The choices may legally cover some of the static predicate sets, -- but not all. Emit an error for each non-covered set. @@ -977,7 +1049,7 @@ package body Sem_Case is -- Special case: only an others case is present. The others case -- covers the full range of the type. - if Is_Static_Subtype (Choice_Type) then + if Is_OK_Static_Subtype (Choice_Type) then Choice := New_Occurrence_Of (Choice_Type, Loc); else Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc); @@ -1268,9 +1340,9 @@ package body Sem_Case is -- Do not insert non static choices in the table to be sorted - elsif not Is_Static_Expression (Lo) + elsif not Is_OK_Static_Expression (Lo) or else - not Is_Static_Expression (Hi) + not Is_OK_Static_Expression (Hi) then Process_Non_Static_Choice (Choice); return; @@ -1387,7 +1459,7 @@ package body Sem_Case is if Is_OK_Static_Subtype (Subtyp) then if not Has_Predicates (Subtyp) - or else Present (Static_Predicate (Subtyp)) + or else Has_Static_Predicate (Subtyp) then Bounds_Type := Subtyp; else @@ -1464,7 +1536,8 @@ package body Sem_Case is -- Use of non-static predicate is an error if not Is_Discrete_Type (E) - or else No (Static_Predicate (E)) + or else not Has_Static_Predicate (E) + or else Has_Dynamic_Predicate_Aspect (E) then Bad_Predicated_Subtype_Use ("cannot use subtype& with non-static " @@ -1484,7 +1557,7 @@ package body Sem_Case is -- list is empty, corresponding to a False -- predicate, then no choices are checked. - P := First (Static_Predicate (E)); + P := First (Static_Discrete_Predicate (E)); while Present (P) loop C := New_Copy (P); Set_Sloc (C, Sloc (Choice)); @@ -1498,7 +1571,7 @@ package body Sem_Case is -- Not predicated subtype case - elsif not Is_Static_Subtype (E) then + elsif not Is_OK_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else Check @@ -1522,7 +1595,7 @@ package body Sem_Case is begin E := Entity (Subtype_Mark (Choice)); - if not Is_Static_Subtype (E) then + if not Is_OK_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else diff --git a/main/gcc/ada/sem_cat.adb b/main/gcc/ada/sem_cat.adb index b9800c40a9b..9a65a05bb4f 100644 --- a/main/gcc/ada/sem_cat.adb +++ b/main/gcc/ada/sem_cat.adb @@ -355,7 +355,7 @@ package body Sem_Cat is loop if Present (Expression (Component_Decl)) and then Nkind (Expression (Component_Decl)) /= N_Null - and then not Is_Static_Expression (Expression (Component_Decl)) + and then not Is_OK_Static_Expression (Expression (Component_Decl)) then Error_Msg_Sloc := Sloc (Component_Decl); Error_Msg_F @@ -815,7 +815,8 @@ package body Sem_Cat is Discriminant_Spec := First (L); while Present (Discriminant_Spec) loop if Present (Expression (Discriminant_Spec)) - and then not Is_Static_Expression (Expression (Discriminant_Spec)) + and then + not Is_OK_Static_Expression (Expression (Discriminant_Spec)) then return False; end if; diff --git a/main/gcc/ada/sem_cat.ads b/main/gcc/ada/sem_cat.ads index 1c7f5722ee1..5e05a69a49a 100644 --- a/main/gcc/ada/sem_cat.ads +++ b/main/gcc/ada/sem_cat.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -110,7 +110,7 @@ package Sem_Cat is -- the checks cannot be made before knowing if the object is imported. procedure Validate_RCI_Declarations (P : Entity_Id); - -- Apply semantic checks given in E2.3(10-14) + -- Apply semantic checks given in E2.3(10-14) procedure Validate_RCI_Subprogram_Declaration (N : Node_Id); -- Check RCI subprogram declarations for illegal inlining and formals not @@ -118,10 +118,10 @@ package Sem_Cat is procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id); -- Checks that Storage_Pool and Storage_Size attribute references are - -- not applied to remote access-to-class-wide types. And the expected - -- type for an allocator shall not be a remote access-to-class-wide - -- type. And a remote access-to-class-wide type shall not be an actual - -- parameter for a generic formal access type. RM E.2.3(22). + -- not applied to remote access-to-class-wide types. Also checks that the + -- expected type for an allocator cannot be a remote access-to-class-wide + -- type. ALso checks that a remote access-to-class-wide type cannot be an + -- actual parameter for a generic formal access type. RM E.2.3(22). procedure Validate_RT_RAT_Component (N : Node_Id); -- Given N, the package library unit declaration node, we should check diff --git a/main/gcc/ada/sem_ch10.adb b/main/gcc/ada/sem_ch10.adb index 8330c427da1..4bfd25bbb55 100644 --- a/main/gcc/ada/sem_ch10.adb +++ b/main/gcc/ada/sem_ch10.adb @@ -87,6 +87,10 @@ package body Sem_Ch10 is -- Check whether the source for the body of a compilation unit must be -- included in a standalone library. + procedure Check_No_Elab_Code_All (N : Node_Id); + -- Carries out possible tests for violation of No_Elab_Code all for withed + -- units in the Context_Items of unit N. + procedure Check_Private_Child_Unit (N : Node_Id); -- If a with_clause mentions a private child unit, the compilation unit -- must be a member of the same family, as described in 10.1.2. @@ -109,13 +113,6 @@ package body Sem_Ch10 is -- and of subunits. N is a defining_program_unit_name, and P_Id is the -- immediate parent scope. - function Get_Parent_Entity (Unit : Node_Id) return Entity_Id; - -- Get defining entity of parent unit of a child unit. In most cases this - -- is the defining entity of the unit, but for a child instance whose - -- parent needs a body for inlining, the instantiation node of the parent - -- has not yet been rewritten as a package declaration, and the entity has - -- to be retrieved from the Instance_Spec of the unit. - function Has_With_Clause (C_Unit : Node_Id; Pack : Entity_Id; @@ -242,7 +239,7 @@ package body Sem_Ch10 is -- on the context. Note that in contrast with the handling of private -- types, the limited view and the non-limited view of a type are treated -- as separate entities, and no entity exchange needs to take place, which - -- makes the implementation must simpler than could be feared. + -- makes the implementation much simpler than could be feared. ------------------------------ -- Analyze_Compilation_Unit -- @@ -512,6 +509,13 @@ package body Sem_Ch10 is and then not Implicit_With (Clause) and then not Limited_Present (Clause) and then not Elaborate_Present (Clause) + + -- With_clauses introduced for renamings of parent clauses + -- are not marked implicit because they need to be properly + -- installed, but they do not come from source and do not + -- require warnings. + + and then Comes_From_Source (Clause) then -- Package body-to-spec check @@ -1196,8 +1200,15 @@ package body Sem_Ch10 is Set_Analyzed (N); + -- Call Check_Package_Body so that a body containing subprograms with + -- Inline_Always can be made available for front end inlining. + if Nkind (Unit_Node) = N_Package_Declaration and then Get_Cunit_Unit_Number (N) /= Main_Unit + + -- We don't need to do this if the Expander is not active, since there + -- is no code to inline. + and then Expander_Active then declare @@ -1209,7 +1220,8 @@ package body Sem_Ch10 is Save_Style_Check_Options (Options); Reset_Style_Check_Options; Opt.Warning_Mode := Suppress; - Check_Body_For_Inlining (N, Defining_Entity (Unit_Node)); + + Check_Package_Body_For_Inlining (N, Defining_Entity (Unit_Node)); Reset_Style_Check_Options; Set_Style_Check_Options (Options); @@ -1271,6 +1283,13 @@ package body Sem_Ch10 is Pop_Scope; end if; + + -- If No_Elaboration_Code_All was encountered, this is where we do the + -- transitive test of with'ed units to make sure they have the aspect. + -- This is delayed till the end of analyzing the compilation unit to + -- ensure that the pragma/aspect, if present, has been analyzed. + + Check_No_Elab_Code_All (N); end Analyze_Compilation_Unit; --------------------- @@ -1312,7 +1331,7 @@ package body Sem_Ch10 is -- a) The first pass analyzes non-limited with-clauses and also any -- configuration pragmas (we need to get the latter analyzed right - -- away, since they can affect processing of subsequent items. + -- away, since they can affect processing of subsequent items). -- b) The second pass analyzes limited_with clauses (Ada 2005: AI-50217) @@ -1325,19 +1344,26 @@ package body Sem_Ch10 is and then not Limited_Present (Item) then -- Skip analyzing with clause if no unit, nothing to do (this - -- happens for a with that references a non-existent unit). Skip - -- as well if this is a with_clause for the main unit, which - -- happens if a subunit has a useless with_clause on its parent. + -- happens for a with that references a non-existent unit). if Present (Library_Unit (Item)) then + + -- Skip analyzing with clause if this is a with_clause for + -- the main unit, which happens if a subunit has a useless + -- with_clause on its parent. + if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then Analyze (Item); + -- Here for the case of a useless with for the main unit + else Set_Entity (Name (Item), Cunit_Entity (Current_Sem_Unit)); end if; end if; + -- Do version update (skipped for implicit with) + if not Implicit_With (Item) then Version_Update (N, Library_Unit (Item)); end if; @@ -1616,6 +1642,7 @@ package body Sem_Ch10 is Set_Corresponding_Stub (Unit (Comp_Unit), N); Analyze_Subunit (Comp_Unit); Set_Library_Unit (N, Comp_Unit); + Set_Corresponding_Body (N, Defining_Entity (Unit (Comp_Unit))); end if; elsif Unum = No_Unit @@ -1705,15 +1732,22 @@ package body Sem_Ch10 is -- should be ignored, except that if we are building trees for ASIS -- usage we want to annotate the stub properly. If the main unit is -- itself a subunit, another subunit is irrelevant unless it is a - -- subunit of the current one. + -- subunit of the current one, that is to say appears in the current + -- source tree. elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit and then Subunit_Name /= Unit_Name (Main_Unit) then - if ASIS_Mode - and then Scope (Defining_Entity (N)) = Cunit_Entity (Main_Unit) - then - Optional_Subunit; + if ASIS_Mode then + declare + PB : constant Node_Id := Proper_Body (Unit (Cunit (Main_Unit))); + begin + if Nkind_In (PB, N_Package_Body, N_Subprogram_Body) + and then List_Containing (N) = Declarations (PB) + then + Optional_Subunit; + end if; + end; end if; -- But before we return, set the flag for unloaded subunits. This @@ -2038,6 +2072,7 @@ package body Sem_Ch10 is begin Analyze_Context (N); + Check_No_Elab_Code_All (N); -- Make withed units immediately visible. If child unit, make the -- ultimate parent immediately visible. @@ -3098,24 +3133,6 @@ package body Sem_Ch10 is end if; end Generate_Parent_References; - ----------------------- - -- Get_Parent_Entity -- - ----------------------- - - function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is - begin - if Nkind (Unit) = N_Package_Body - and then Nkind (Original_Node (Unit)) = N_Package_Instantiation - then - return Defining_Entity - (Specification (Instance_Spec (Original_Node (Unit)))); - elsif Nkind (Unit) = N_Package_Instantiation then - return Defining_Entity (Specification (Instance_Spec (Unit))); - else - return Defining_Entity (Unit); - end if; - end Get_Parent_Entity; - --------------------- -- Has_With_Clause -- --------------------- @@ -3591,7 +3608,7 @@ package body Sem_Ch10 is procedure Check_Private_Limited_Withed_Unit (Item : Node_Id); -- Check that if a limited_with clause of a given compilation_unit -- mentions a descendant of a private child of some library unit, then - -- the given compilation_unit shall be the declaration of a private + -- the given compilation_unit must be the declaration of a private -- descendant of that library unit, or a public descendant of such. The -- code is analogous to that of Check_Private_Child_Unit but we cannot -- use entities on the limited with_clauses because their units have not @@ -5678,13 +5695,11 @@ package body Sem_Ch10 is ------------------- procedure Process_State (State : Node_Id) is - Loc : constant Source_Ptr := Sloc (State); - Elmt : Node_Id; - Id : Entity_Id; - Name : Name_Id; - + Loc : constant Source_Ptr := Sloc (State); + Decl : Node_Id; Dummy : Entity_Id; - pragma Unreferenced (Dummy); + Elmt : Node_Id; + Id : Entity_Id; begin -- Multiple abstract states appear as an aggregate @@ -5693,9 +5708,9 @@ package body Sem_Ch10 is Elmt := First (Expressions (State)); while Present (Elmt) loop Process_State (Elmt); - Next (Elmt); end loop; + return; -- A null state has no abstract view @@ -5707,12 +5722,12 @@ package body Sem_Ch10 is -- extension aggregate. elsif Nkind (State) = N_Extension_Aggregate then - Name := Chars (Ancestor_Part (State)); + Decl := Ancestor_Part (State); -- Simple state declaration elsif Nkind (State) = N_Identifier then - Name := Chars (State); + Decl := State; -- Possibly an illegal state declaration @@ -5720,14 +5735,26 @@ package body Sem_Ch10 is return; end if; - -- Construct a dummy state for the purposes of establishing a - -- non-limited => limited view relation. Note that the dummy - -- state is not added to list Abstract_States to avoid multiple - -- definitions. + -- Abstract states are elaborated when the related pragma is + -- elaborated. Since the withed package is not analyzed yet, + -- the entities of the abstract states are not available. To + -- overcome this complication, create the entities now and + -- store them in their respective declarations. The entities + -- are later used by routine Create_Abstract_State to declare + -- and enter the states into visibility. + + if No (Entity (Decl)) then + Id := Make_Defining_Identifier (Loc, Chars (Decl)); + + Set_Entity (Decl, Id); + Set_Parent (Id, State); + Decorate_State (Id, Scop); + + -- Otherwise the package was previously withed - Id := Make_Defining_Identifier (Loc, New_External_Name (Name)); - Set_Parent (Id, State); - Decorate_State (Id, Scop); + else + Id := Entity (Decl); + end if; Build_Shadow_Entity (Id, Scop, Dummy); end Process_State; @@ -6040,6 +6067,41 @@ package body Sem_Ch10 is Set_Limited_View_Installed (Spec); end Build_Limited_Views; + ---------------------------- + -- Check_No_Elab_Code_All -- + ---------------------------- + + procedure Check_No_Elab_Code_All (N : Node_Id) is + begin + if Present (No_Elab_Code_All_Pragma) + and then In_Extended_Main_Source_Unit (N) + and then Present (Context_Items (N)) + then + declare + CL : constant List_Id := Context_Items (N); + CI : Node_Id; + + begin + CI := First (CL); + while Present (CI) loop + if Nkind (CI) = N_With_Clause + and then not + No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI))) + then + Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma); + Error_Msg_N + ("violation of No_Elaboration_Code_All#", CI); + Error_Msg_NE + ("\unit& does not have No_Elaboration_Code_All", + CI, Entity (Name (CI))); + end if; + + Next (CI); + end loop; + end; + end if; + end Check_No_Elab_Code_All; + ------------------------------- -- Check_Body_Needed_For_SAL -- ------------------------------- diff --git a/main/gcc/ada/sem_ch11.adb b/main/gcc/ada/sem_ch11.adb index c4a148f0cd5..45b4a082a47 100644 --- a/main/gcc/ada/sem_ch11.adb +++ b/main/gcc/ada/sem_ch11.adb @@ -46,7 +46,6 @@ with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Stand; use Stand; -with Uintp; use Uintp; package body Sem_Ch11 is @@ -61,7 +60,6 @@ package body Sem_Ch11 is Generate_Definition (Id); Enter_Name (Id); Set_Ekind (Id, E_Exception); - Set_Exception_Code (Id, Uint_0); Set_Etype (Id, Standard_Exception_Type); Set_Is_Statically_Allocated (Id); Set_Is_Pure (Id, PF); @@ -439,7 +437,7 @@ package body Sem_Ch11 is Check_Compiler_Unit ("raise expression", N); end if; - Check_SPARK_Restriction ("raise expression is not allowed", N); + Check_SPARK_05_Restriction ("raise expression is not allowed", N); -- Check exception restrictions on the original source @@ -497,7 +495,7 @@ package body Sem_Ch11 is begin if Comes_From_Source (N) then - Check_SPARK_Restriction ("raise statement is not allowed", N); + Check_SPARK_05_Restriction ("raise statement is not allowed", N); end if; Check_Unreachable_Code (N); @@ -704,7 +702,7 @@ package body Sem_Ch11 is begin if Nkind (Original_Node (N)) = N_Raise_Statement then - Check_SPARK_Restriction ("raise statement is not allowed", N); + Check_SPARK_05_Restriction ("raise statement is not allowed", N); end if; if No (Etype (N)) then diff --git a/main/gcc/ada/sem_ch12.adb b/main/gcc/ada/sem_ch12.adb index 24dfa4e51d7..dd8badb1065 100644 --- a/main/gcc/ada/sem_ch12.adb +++ b/main/gcc/ada/sem_ch12.adb @@ -25,12 +25,12 @@ with Aspects; use Aspects; with Atree; use Atree; -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_Util; use Exp_Util; with Fname; use Fname; with Fname.UF; use Fname.UF; with Freeze; use Freeze; @@ -954,6 +954,15 @@ package body Sem_Ch12 is -- In Ada 2005, indicates partial parameterization of a formal -- package. As usual an other association must be last in the list. + function Build_Wrapper + (Formal : Entity_Id; + Actual : Entity_Id := Empty) return Node_Id; + -- In GNATProve mode, create a wrapper function for actuals that are + -- operators, in order to propagate their contract to the renaming + -- declarations generated for them. If the actual is absent, this is + -- a formal with a default, and the name of the operator is that of the + -- formal. + 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 @@ -1001,6 +1010,149 @@ package body Sem_Ch12 is -- anonymous types, the presence a formal equality will introduce an -- implicit declaration for the corresponding inequality. + ------------------- + -- Build_Wrapper -- + ------------------- + + function Build_Wrapper + (Formal : Entity_Id; + Actual : Entity_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (I_Node); + Typ : constant Entity_Id := Etype (Formal); + Is_Binary : constant Boolean := + Present (Next_Formal (First_Formal (Formal))); + + Decl : Node_Id; + Expr : Node_Id; + F1, F2 : Entity_Id; + Func : Entity_Id; + Op_Name : Name_Id; + Spec : Node_Id; + + L, R : Node_Id; + + begin + if No (Actual) then + Op_Name := Chars (Formal); + else + Op_Name := Chars (Actual); + end if; + + -- Create entities for wrapper function and its formals + + F1 := Make_Temporary (Loc, 'A'); + F2 := Make_Temporary (Loc, 'B'); + L := New_Occurrence_Of (F1, Loc); + R := New_Occurrence_Of (F2, Loc); + + Func := Make_Defining_Identifier (Loc, Chars (Formal)); + Set_Ekind (Func, E_Function); + Set_Is_Generic_Actual_Subprogram (Func); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Func, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => F1, + Parameter_Type => + Make_Identifier (Loc, + Chars => Chars (Etype (First_Formal (Formal)))))), + Result_Definition => Make_Identifier (Loc, Chars (Typ))); + + if Is_Binary then + Append_To (Parameter_Specifications (Spec), + Make_Parameter_Specification (Loc, + Defining_Identifier => F2, + Parameter_Type => + Make_Identifier (Loc, + Chars (Etype (Next_Formal (First_Formal (Formal))))))); + end if; + + -- Build expression as a function call, or as an operator node + -- that corresponds to the name of the actual, starting with binary + -- operators. + + if Present (Actual) and then Op_Name not in Any_Operator_Name then + Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Entity (Actual), Loc), + Parameter_Associations => New_List (L)); + + if Is_Binary then + Append_To (Parameter_Associations (Expr), R); + end if; + + -- Binary operators + + elsif Is_Binary then + if Op_Name = Name_Op_And then + Expr := Make_Op_And (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Or then + Expr := Make_Op_Or (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Xor then + Expr := Make_Op_Xor (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Eq then + Expr := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Ne then + Expr := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Le then + Expr := Make_Op_Le (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Gt then + Expr := Make_Op_Gt (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Ge then + Expr := Make_Op_Ge (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Lt then + Expr := Make_Op_Lt (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Add then + Expr := Make_Op_Add (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Subtract then + Expr := Make_Op_Subtract (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Concat then + Expr := Make_Op_Concat (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Multiply then + Expr := Make_Op_Multiply (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Divide then + Expr := Make_Op_Divide (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Mod then + Expr := Make_Op_Mod (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Rem then + Expr := Make_Op_Rem (Loc, Left_Opnd => L, Right_Opnd => R); + elsif Op_Name = Name_Op_Expon then + Expr := Make_Op_Expon (Loc, Left_Opnd => L, Right_Opnd => R); + end if; + + -- Unary operators + + else + if Op_Name = Name_Op_Add then + Expr := Make_Op_Plus (Loc, Right_Opnd => L); + elsif Op_Name = Name_Op_Subtract then + Expr := Make_Op_Minus (Loc, Right_Opnd => L); + elsif Op_Name = Name_Op_Abs then + Expr := Make_Op_Abs (Loc, Right_Opnd => L); + elsif Op_Name = Name_Op_Not then + Expr := Make_Op_Not (Loc, Right_Opnd => L); + end if; + end if; + + -- Propagate visible entity to operator node, either from a + -- given actual or from a default. + + if Is_Entity_Name (Actual) and then Nkind (Expr) in N_Op then + Set_Entity (Expr, Entity (Actual)); + end if; + + Decl := + Make_Expression_Function (Loc, + Specification => Spec, + Expression => Expr); + + return Decl; + end Build_Wrapper; + ---------------------------------------- -- Check_Overloaded_Formal_Subprogram -- ---------------------------------------- @@ -1517,9 +1669,63 @@ package body Sem_Ch12 is end if; else - Append_To (Assoc, - Instantiate_Formal_Subprogram - (Formal, Match, Analyzed_Formal)); + if GNATprove_Mode + and then + Present + (Get_First_Parent_With_Ext_Axioms_For_Entity + (Defining_Entity (Analyzed_Formal))) + and then Ekind (Defining_Entity (Analyzed_Formal)) = + E_Function + then + -- If actual is an entity (function or operator), + -- build wrapper for it. + + if Present (Match) then + if Nkind (Match) = N_Operator_Symbol then + + -- If the name is a default, find its visible + -- entity at the point of instantiation. + + if Is_Entity_Name (Match) + and then No (Entity (Match)) + then + Find_Direct_Name (Match); + end if; + + Append_To + (Assoc, + Build_Wrapper + (Defining_Entity (Analyzed_Formal), Match)); + + else + Append_To (Assoc, + Instantiate_Formal_Subprogram + (Formal, Match, Analyzed_Formal)); + end if; + + -- Ditto if formal is an operator with a default. + + elsif Box_Present (Formal) + and then Nkind (Defining_Entity (Analyzed_Formal)) = + N_Defining_Operator_Symbol + then + Append_To (Assoc, + Build_Wrapper + (Defining_Entity (Analyzed_Formal))); + + -- Otherwise create renaming declaration. + + else + Append_To (Assoc, + Instantiate_Formal_Subprogram + (Formal, Match, Analyzed_Formal)); + end if; + + else + Append_To (Assoc, + Instantiate_Formal_Subprogram + (Formal, Match, Analyzed_Formal)); + end if; -- An instantiation is a freeze point for the actuals, -- unless this is a rewritten formal package. @@ -1556,9 +1762,7 @@ package body Sem_Ch12 is -- If this is a nested generic, preserve default for later -- instantiations. - if No (Match) - and then Box_Present (Formal) - then + if No (Match) and then Box_Present (Formal) then Append_Elmt (Defining_Unit_Name (Specification (Last (Assoc))), Default_Actuals); @@ -2992,7 +3196,7 @@ package body Sem_Ch12 is Decl : Node_Id; begin - Check_SPARK_Restriction ("generic is not allowed", N); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- We introduce a renaming of the enclosing package, to have a usable -- entity as the prefix of an expanded name for a local entity of the @@ -3125,7 +3329,7 @@ package body Sem_Ch12 is Typ : Entity_Id; begin - Check_SPARK_Restriction ("generic is not allowed", N); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Create copy of generic unit, and save for instantiation. If the unit -- is a child unit, do not copy the specifications for the parent, which @@ -3138,21 +3342,10 @@ package body Sem_Ch12 is Set_Parent_Spec (New_N, Save_Parent); Rewrite (N, New_N); - Check_SPARK_Mode_In_Generic (N); - - -- The aspect specifications are not attached to the tree, and must - -- be copied and attached to the generic copy explicitly. + -- Once the contents of the generic copy and the template are swapped, + -- do the same for their respective aspect specifications. - if Present (Aspect_Specifications (New_N)) then - declare - Aspects : constant List_Id := Aspect_Specifications (N); - begin - Set_Has_Aspects (N, False); - Move_Aspects (New_N, To => N); - Set_Has_Aspects (Original_Node (N), False); - Set_Aspect_Specifications (Original_Node (N), Aspects); - end; - end if; + Exchange_Aspects (N, New_N); Spec := Specification (N); Id := Defining_Entity (Spec); @@ -3167,8 +3360,15 @@ package body Sem_Ch12 is Start_Generic; Enter_Name (Id); - Set_Scope_Depth_Value (Id, Scope_Depth (Current_Scope) + 1); + + -- Analyze the aspects of the generic copy to ensure that all generated + -- pragmas (if any) perform their semantic effects. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Id); + end if; + Push_Scope (Id); Enter_Generic_Scope (Id); Set_Inner_Instances (Id, New_Elmt_List); @@ -3258,41 +3458,6 @@ package body Sem_Ch12 is Make_Aspect_For_PPC_In_Gen_Sub_Decl (N); end if; - -- To capture global references, analyze the expressions of aspects, - -- and propagate information to original tree. Note that in this case - -- analysis of attributes is not delayed until the freeze point. - - -- It seems very hard to recreate the proper visibility of the generic - -- subprogram at a later point because the analysis of an aspect may - -- create pragmas after the generic copies have been made ??? - - if Has_Aspects (N) then - declare - Aspect : Node_Id; - - begin - Aspect := First (Aspect_Specifications (N)); - while Present (Aspect) loop - if Get_Aspect_Id (Aspect) /= Aspect_Warnings - and then Present (Expression (Aspect)) - then - Analyze (Expression (Aspect)); - end if; - - Next (Aspect); - end loop; - - Aspect := First (Aspect_Specifications (Original_Node (N))); - while Present (Aspect) loop - if Present (Expression (Aspect)) then - Save_Global_References (Expression (Aspect)); - end if; - - Next (Aspect); - end loop; - end; - end if; - End_Generic; End_Scope; Exit_Generic_Scope (Id); @@ -3328,6 +3493,13 @@ package body Sem_Ch12 is Needs_Body : Boolean; Inline_Now : Boolean := False; + Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; + -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit + + Save_SM : constant SPARK_Mode_Type := SPARK_Mode; + Save_SMP : constant Node_Id := SPARK_Mode_Pragma; + -- Save the SPARK_Mode-related data for restore on exit + Save_Style_Check : constant Boolean := Style_Check; -- Save style check mode for restore on exit @@ -3421,7 +3593,7 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Package_Instantiation begin - Check_SPARK_Restriction ("generic is not allowed", N); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Very first thing: check for Text_IO sp[ecial unit in case we are -- instantiating one of the children of [[Wide_]Wide_]Text_IO. @@ -3567,6 +3739,14 @@ package body Sem_Ch12 is goto Leave; else + -- If the context of the instance is subject to SPARK_Mode "off", + -- set the global flag which signals Analyze_Pragma to ignore all + -- SPARK_Mode pragmas within the instance. + + if SPARK_Mode = Off then + Ignore_Pragma_SPARK_Mode := True; + end if; + Gen_Decl := Unit_Declaration_Node (Gen_Unit); -- Initialize renamings map, for error checking, and the list that @@ -3631,9 +3811,7 @@ package body Sem_Ch12 is Set_Visible_Declarations (Act_Spec, Renaming_List); end if; - Act_Decl := - Make_Package_Declaration (Loc, - Specification => Act_Spec); + Act_Decl := Make_Package_Declaration (Loc, Specification => Act_Spec); -- Propagate the aspect specifications from the package declaration -- template to the instantiated version of the package declaration. @@ -3698,7 +3876,7 @@ package body Sem_Ch12 is and then Might_Inline_Subp and then not Is_Actual_Pack then - if not Debug_Flag_Dot_K + if not Back_End_Inlining and then Front_End_Inlining and then (Is_In_Main_Unit (N) or else In_Main_Context (Current_Scope)) @@ -3706,7 +3884,7 @@ package body Sem_Ch12 is then Inline_Now := True; - elsif Debug_Flag_Dot_K + elsif Back_End_Inlining and then Must_Inline_Subp and then (Is_In_Main_Unit (N) or else In_Main_Context (Current_Scope)) @@ -4073,7 +4251,10 @@ package body Sem_Ch12 is Set_Defining_Identifier (N, Act_Decl_Id); end if; - Style_Check := Save_Style_Check; + Ignore_Pragma_SPARK_Mode := Save_IPSM; + SPARK_Mode := Save_SM; + SPARK_Mode_Pragma := Save_SMP; + Style_Check := Save_Style_Check; -- Check that if N is an instantiation of System.Dim_Float_IO or -- System.Dim_Integer_IO, the formal type has a dimension system. @@ -4107,7 +4288,10 @@ package body Sem_Ch12 is Restore_Env; end if; - Style_Check := Save_Style_Check; + Ignore_Pragma_SPARK_Mode := Save_IPSM; + SPARK_Mode := Save_SM; + SPARK_Mode_Pragma := Save_SMP; + Style_Check := Save_Style_Check; end Analyze_Package_Instantiation; -------------------------- @@ -4661,6 +4845,13 @@ package body Sem_Ch12 is -- Local variables + Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode; + -- Save flag Ignore_Pragma_SPARK_Mode for restore on exit + + Save_SM : constant SPARK_Mode_Type := SPARK_Mode; + Save_SMP : constant Node_Id := SPARK_Mode_Pragma; + -- Save the SPARK_Mode-related data for restore on exit + Vis_Prims_List : Elist_Id := No_Elist; -- List of primitives made temporarily visible in the instantiation -- to match the visibility of the formal type @@ -4668,7 +4859,7 @@ package body Sem_Ch12 is -- Start of processing for Analyze_Subprogram_Instantiation begin - Check_SPARK_Restriction ("generic is not allowed", N); + Check_SPARK_05_Restriction ("generic is not allowed", N); -- Very first thing: check for special Text_IO unit in case we are -- instantiating one of the children of [[Wide_]Wide_]Text_IO. Of course @@ -4725,6 +4916,14 @@ package body Sem_Ch12 is Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit); else + -- If the context of the instance is subject to SPARK_Mode "off", + -- set the global flag which signals Analyze_Pragma to ignore all + -- SPARK_Mode pragmas within the instance. + + if SPARK_Mode = Off then + Ignore_Pragma_SPARK_Mode := True; + end if; + Set_Entity (Gen_Id, Gen_Unit); Set_Is_Instantiated (Gen_Unit); @@ -4935,6 +5134,10 @@ package body Sem_Ch12 is Env_Installed := False; Generic_Renamings.Set_Last (0); Generic_Renamings_HTable.Reset; + + Ignore_Pragma_SPARK_Mode := Save_IPSM; + SPARK_Mode := Save_SM; + SPARK_Mode_Pragma := Save_SMP; end if; <> @@ -4951,6 +5154,10 @@ package body Sem_Ch12 is if Env_Installed then Restore_Env; end if; + + Ignore_Pragma_SPARK_Mode := Save_IPSM; + SPARK_Mode := Save_SM; + SPARK_Mode_Pragma := Save_SMP; end Analyze_Subprogram_Instantiation; ------------------------- @@ -5336,9 +5543,8 @@ package body Sem_Ch12 is Expr2 := Expression (Parent (E2)); end if; - if Is_Static_Expression (Expr1) then - - if not Is_Static_Expression (Expr2) then + if Is_OK_Static_Expression (Expr1) then + if not Is_OK_Static_Expression (Expr2) then Check_Mismatch (True); elsif Is_Discrete_Type (Etype (E1)) then @@ -8725,12 +8931,7 @@ package body Sem_Ch12 is and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) then Set_Chars (Prim_A, Chars (Prim_G)); - - if List = No_Elist then - List := New_Elmt_List; - end if; - - Append_Elmt (Prim_A, List); + Append_New_Elmt (Prim_A, To => List); end if; Next_Elmt (Prim_A_Elmt); @@ -9263,14 +9464,10 @@ package body Sem_Ch12 is Actual : Node_Id; Analyzed_Formal : Node_Id) return Node_Id is - Loc : Source_Ptr; - Formal_Sub : constant Entity_Id := - Defining_Unit_Name (Specification (Formal)); Analyzed_S : constant Entity_Id := Defining_Unit_Name (Specification (Analyzed_Formal)); - Decl_Node : Node_Id; - Nam : Node_Id; - New_Spec : Node_Id; + Formal_Sub : constant Entity_Id := + Defining_Unit_Name (Specification (Formal)); function From_Parent_Scope (Subp : Entity_Id) return Boolean; -- If the generic is a child unit, the parent has been installed on the @@ -9337,9 +9534,15 @@ package body Sem_Ch12 is ("expect subprogram or entry name in instantiation of&", Instantiation_Node, Formal_Sub); Abandon_Instantiation (Instantiation_Node); - end Valid_Actual_Subprogram; + -- Local variables + + Decl_Node : Node_Id; + Loc : Source_Ptr; + Nam : Node_Id; + New_Spec : Node_Id; + -- Start of processing for Instantiate_Formal_Subprogram begin @@ -9356,18 +9559,21 @@ package body Sem_Ch12 is Set_Defining_Unit_Name (New_Spec, Make_Defining_Identifier (Loc, Chars (Formal_Sub))); - -- Create new entities for the each of the formals in the - -- specification of the renaming declaration built for the actual. + -- Create new entities for the each of the formals in the specification + -- of the renaming declaration built for the actual. if Present (Parameter_Specifications (New_Spec)) then declare - F : Node_Id; + F : Node_Id; + F_Id : Entity_Id; + begin F := First (Parameter_Specifications (New_Spec)); while Present (F) loop + F_Id := Defining_Identifier (F); + Set_Defining_Identifier (F, - Make_Defining_Identifier (Sloc (F), - Chars => Chars (Defining_Identifier (F)))); + Make_Defining_Identifier (Sloc (F_Id), Chars (F_Id))); Next (F); end loop; end; @@ -9416,9 +9622,10 @@ package body Sem_Ch12 is -- identifier or operator with the same name as the formal. if Nkind (Formal_Sub) = N_Defining_Operator_Symbol then - Nam := Make_Operator_Symbol (Loc, - Chars => Chars (Formal_Sub), - Strval => No_String); + Nam := + Make_Operator_Symbol (Loc, + Chars => Chars (Formal_Sub), + Strval => No_String); else Nam := Make_Identifier (Loc, Chars (Formal_Sub)); end if; @@ -9465,9 +9672,7 @@ package body Sem_Ch12 is -- instance. If overloaded, it will be resolved when analyzing the -- renaming declaration. - if Box_Present (Formal) - and then No (Actual) - then + if Box_Present (Formal) and then No (Actual) then Analyze (Nam); if Is_Child_Unit (Scope (Analyzed_S)) @@ -9906,13 +10111,13 @@ package body Sem_Ch12 is ("actual must exclude null to match generic formal#", Actual); end if; - -- A volatile object cannot be used as an actual in a generic instance. - -- The following check is only relevant when SPARK_Mode is on as it is - -- not a standard Ada legality rule. + -- An effectively volatile object cannot be used as an actual in + -- a generic instance. The following check is only relevant when + -- SPARK_Mode is on as it is not a standard Ada legality rule. if SPARK_Mode = On and then Present (Actual) - and then Is_SPARK_Volatile_Object (Actual) + and then Is_Effectively_Volatile_Object (Actual) then Error_Msg_N ("volatile object cannot act as actual in generic instantiation " @@ -10203,8 +10408,7 @@ package body Sem_Ch12 is -- to be compiled with checks off. -- Note that we do NOT apply this criterion to children of GNAT - -- (or on VMS, children of DEC). The latter units must suppress - -- checks explicitly if this is needed. + -- The latter units must suppress checks explicitly if needed. if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Gen_Decl))) @@ -10633,6 +10837,13 @@ package body Sem_Ch12 is Loc : Source_Ptr; Subt : Entity_Id; + procedure Diagnose_Predicated_Actual; + -- There are a number of constructs in which a discrete type with + -- predicates is illegal, e.g. as an index in an array type declaration. + -- If a generic type is used is such a construct in a generic package + -- declaration, it carries the flag No_Predicate_On_Actual. it is part + -- of the generic contract that the actual cannot have predicates. + procedure Validate_Array_Type_Instance; procedure Validate_Access_Subprogram_Instance; procedure Validate_Access_Type_Instance; @@ -10650,6 +10861,29 @@ package body Sem_Ch12 is -- Check that base types are the same and that the subtypes match -- statically. Used in several of the above. + --------------------------------- + -- Diagnose_Predicated_Actual -- + --------------------------------- + + procedure Diagnose_Predicated_Actual is + begin + if No_Predicate_On_Actual (A_Gen_T) + and then Has_Predicates (Act_T) + then + Error_Msg_NE + ("actual for& cannot be a type with predicate", + Instantiation_Node, A_Gen_T); + + elsif No_Dynamic_Predicate_On_Actual (A_Gen_T) + and then Has_Predicates (Act_T) + and then not Has_Static_Predicate_Aspect (Act_T) + then + Error_Msg_NE + ("actual for& cannot be a type with a dynamic predicate", + Instantiation_Node, A_Gen_T); + end if; + end Diagnose_Predicated_Actual; + -------------------- -- Subtypes_Match -- -------------------- @@ -11188,7 +11422,7 @@ package body Sem_Ch12 is ("actual for & cannot be a class-wide type", Actual, Gen_T); Abandon_Instantiation (Actual); - -- Otherwise, the formal and actual shall have the same number + -- Otherwise, the formal and actual must have the same number -- of discriminants and each discriminant of the actual must -- correspond to a discriminant of the formal. @@ -11818,6 +12052,8 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Diagnose_Predicated_Actual; + when N_Formal_Signed_Integer_Type_Definition => if not Is_Signed_Integer_Type (Act_T) then Error_Msg_NE @@ -11826,6 +12062,8 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Diagnose_Predicated_Actual; + when N_Formal_Modular_Type_Definition => if not Is_Modular_Integer_Type (Act_T) then Error_Msg_NE @@ -11834,6 +12072,8 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; + Diagnose_Predicated_Actual; + when N_Formal_Floating_Point_Definition => if not Is_Floating_Point_Type (Act_T) then Error_Msg_NE diff --git a/main/gcc/ada/sem_ch13.adb b/main/gcc/ada/sem_ch13.adb index 390fce7bd09..a73712bfb5f 100644 --- a/main/gcc/ada/sem_ch13.adb +++ b/main/gcc/ada/sem_ch13.adb @@ -97,8 +97,8 @@ package body Sem_Ch13 is -- name, which is unique, so any identifier with Chars matching Nam must be -- a reference to the type. If the predicate is non-static, this procedure -- returns doing nothing. If the predicate is static, then the predicate - -- list is stored in Static_Predicate (Typ), and the Expr is rewritten as - -- a canonicalized membership operation. + -- list is stored in Static_Discrete_Predicate (Typ), and the Expr is + -- rewritten as a canonicalized membership operation. procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id); -- If Typ has predicates (indicated by Has_Predicates being set for Typ), @@ -169,10 +169,10 @@ package body Sem_Ch13 is Nam : TSS_Name_Type); -- Create a subprogram renaming of a given stream attribute to the -- designated subprogram and then in the tagged case, provide this as a - -- primitive operation, or in the non-tagged case make an appropriate TSS + -- primitive operation, or in the untagged case make an appropriate TSS -- entry. This is more properly an expansion activity than just semantics, - -- but the presence of user-defined stream functions for limited types is a - -- legality check, which is why this takes place here rather than in + -- but the presence of user-defined stream functions for limited types + -- is a legality check, which is why this takes place here rather than in -- exp_ch13, where it was previously. Nam indicates the name of the TSS -- function to be generated. -- @@ -182,17 +182,6 @@ package body Sem_Ch13 is -- renaming_as_body. For tagged types, the specification is one of the -- primitive specs. - generic - with procedure Replace_Type_Reference (N : Node_Id); - procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id); - -- This is used to scan an expression for a predicate or invariant aspect - -- replacing occurrences of the name of the subtype to which the aspect - -- applies with appropriate references to the parameter of the predicate - -- function or invariant procedure. The procedure passed as a generic - -- parameter does the actual replacement of node N, which is either a - -- simple direct reference to T, or a selected component that represents - -- an appropriately qualified occurrence of T. - procedure Resolve_Iterable_Operation (N : Node_Id; Cursor : Entity_Id; @@ -932,6 +921,12 @@ package body Sem_Ch13 is and then Reverse_Storage_Order (P) then Set_Reverse_Storage_Order (Base_Type (E)); + + -- Clear default SSO indications, since the aspect + -- overrides the default. + + Set_SSO_Set_Low_By_Default (Base_Type (E), False); + Set_SSO_Set_High_By_Default (Base_Type (E), False); end if; -- Small @@ -1179,45 +1174,41 @@ package body Sem_Ch13 is ----------------------------------- procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is - procedure Decorate_Aspect_And_Pragma - (Asp : Node_Id; - Prag : Node_Id; - Delayed : Boolean := False); - -- Establish the linkages between an aspect and its corresponding - -- pragma. Flag Delayed should be set when both constructs are delayed. + procedure Decorate (Asp : Node_Id; Prag : Node_Id); + -- Establish linkages between an aspect and its corresponding + -- pragma. procedure Insert_After_SPARK_Mode (Prag : Node_Id; Ins_Nod : Node_Id; Decls : List_Id); - -- Subsidiary to the analysis of aspects Abstract_State, Initializes and - -- Initial_Condition. Insert node Prag before node Ins_Nod. If Ins_Nod - -- denotes pragma SPARK_Mode, then SPARK_Mode is skipped. Decls is the - -- associated declarative list where Prag is to reside. - - procedure Insert_Delayed_Pragma (Prag : Node_Id); - -- Insert a postcondition-like pragma into the tree depending on the - -- context. Prag must denote one of the following: Pre, Post, Depends, - -- Global or Contract_Cases. This procedure is also used for the case - -- of Attach_Handler which has similar requirements for placement. - - -------------------------------- - -- Decorate_Aspect_And_Pragma -- - -------------------------------- - - procedure Decorate_Aspect_And_Pragma - (Asp : Node_Id; - Prag : Node_Id; - Delayed : Boolean := False) - is + -- Subsidiary to the analysis of aspects Abstract_State, Initializes, + -- Initial_Condition and Refined_State. Insert node Prag before node + -- Ins_Nod. If Ins_Nod is for pragma SPARK_Mode, then skip SPARK_Mode. + -- Decls is the associated declarative list where Prag is to reside. + + procedure Insert_Pragma (Prag : Node_Id); + -- Subsidiary to the analysis of aspects Attach_Handler, Contract_Cases, + -- Depends, Global, Post, Pre, Refined_Depends and Refined_Global. + -- Insert pragma Prag such that it mimics the placement of a source + -- pragma of the same kind. + -- + -- procedure Proc (Formal : ...) with Global => ...; + -- + -- procedure Proc (Formal : ...); + -- pragma Global (...); + + -------------- + -- Decorate -- + -------------- + + procedure Decorate (Asp : Node_Id; Prag : Node_Id) is begin Set_Aspect_Rep_Item (Asp, Prag); Set_Corresponding_Aspect (Prag, Asp); Set_From_Aspect_Specification (Prag); - Set_Is_Delayed_Aspect (Prag, Delayed); - Set_Is_Delayed_Aspect (Asp, Delayed); Set_Parent (Prag, Asp); - end Decorate_Aspect_And_Pragma; + end Decorate; ----------------------------- -- Insert_After_SPARK_Mode -- @@ -1250,12 +1241,13 @@ package body Sem_Ch13 is end if; end Insert_After_SPARK_Mode; - --------------------------- - -- Insert_Delayed_Pragma -- - --------------------------- + ------------------- + -- Insert_Pragma -- + ------------------- - procedure Insert_Delayed_Pragma (Prag : Node_Id) is - Aux : Node_Id; + procedure Insert_Pragma (Prag : Node_Id) is + Aux : Node_Id; + Decl : Node_Id; begin -- When the context is a library unit, the pragma is added to the @@ -1274,29 +1266,39 @@ package body Sem_Ch13 is -- declarative part. elsif Nkind (N) = N_Subprogram_Body then - if No (Declarations (N)) then - Set_Declarations (N, New_List (Prag)); - else - declare - D : Node_Id; - begin - - -- There may be several aspects associated with the body; - -- preserve the ordering of the corresponding pragmas. - - D := First (Declarations (N)); - while Present (D) loop - exit when Nkind (D) /= N_Pragma - or else not From_Aspect_Specification (D); - Next (D); - end loop; - - if No (D) then - Append (Prag, Declarations (N)); + if Present (Declarations (N)) then + + -- Skip other internally generated pragmas from aspects to find + -- the proper insertion point. As a result the order of pragmas + -- is the same as the order of aspects. + + -- As precondition pragmas generated from conjuncts in the + -- precondition aspect are presented in reverse order to + -- Insert_Pragma, insert them in the correct order here by not + -- skipping previously inserted precondition pragmas when the + -- current pragma is a precondition. + + Decl := First (Declarations (N)); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma + and then From_Aspect_Specification (Decl) + and then not (Get_Pragma_Id (Decl) = Pragma_Precondition + and then + Get_Pragma_Id (Prag) = Pragma_Precondition) + then + Next (Decl); else - Insert_Before (D, Prag); + exit; end if; - end; + end loop; + + if Present (Decl) then + Insert_Before (Decl, Prag); + else + Append (Prag, Declarations (N)); + end if; + else + Set_Declarations (N, New_List (Prag)); end if; -- Default @@ -1304,7 +1306,7 @@ package body Sem_Ch13 is else Insert_After (N, Prag); end if; - end Insert_Delayed_Pragma; + end Insert_Pragma; -- Local variables @@ -1404,7 +1406,7 @@ package body Sem_Ch13 is if No (A) then Error_Msg_N ("missing Import/Export for Link/External name", - Aspect); + Aspect); end if; end; end Analyze_Aspect_External_Or_Link_Name; @@ -1493,7 +1495,7 @@ package body Sem_Ch13 is -- Start of processing for Analyze_One_Aspect begin - -- Skip aspect if already analyzed (not clear if this is needed) + -- Skip aspect if already analyzed, to avoid looping in some cases if Analyzed (Aspect) then goto Continue; @@ -1667,7 +1669,9 @@ package body Sem_Ch13 is and then not (Is_Type (E) and then Is_Tagged_Type (E)) then - Error_Msg_N ("indexing applies to a tagged type", N); + Error_Msg_N + ("indexing aspect can only apply to a tagged type", + Aspect); goto Continue; end if; @@ -1688,10 +1692,10 @@ package body Sem_Ch13 is -- illegal specification of this aspect for a subtype now, -- to prevent malformed rep_item chains. - if (A_Id = Aspect_Input - or else A_Id = Aspect_Output - or else A_Id = Aspect_Read - or else A_Id = Aspect_Write) + if (A_Id = Aspect_Input or else + A_Id = Aspect_Output or else + A_Id = Aspect_Read or else + A_Id = Aspect_Write) and not Is_First_Subtype (E) then Error_Msg_N @@ -1751,7 +1755,7 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Implemented); - -- Attach Handler + -- Attach_Handler when Aspect_Attach_Handler => Make_Aitem_Pragma @@ -1765,7 +1769,7 @@ package body Sem_Ch13 is -- We need to insert this pragma into the tree to get proper -- processing and to look valid from a placement viewpoint. - Insert_Delayed_Pragma (Aitem); + Insert_Pragma (Aitem); goto Continue; -- Dynamic_Predicate, Predicate, Static_Predicate @@ -1774,6 +1778,20 @@ package body Sem_Ch13 is Aspect_Predicate | Aspect_Static_Predicate => + -- These aspects apply only to subtypes + + if not Is_Type (E) then + Error_Msg_N + ("predicate can only be specified for a subtype", + Aspect); + goto Continue; + + elsif Is_Incomplete_Type (E) then + Error_Msg_N + ("predicate cannot apply to incomplete view", Aspect); + goto Continue; + end if; + -- Construct the pragma (always a pragma Predicate, with -- flags recording whether it is static/dynamic). We also -- set flags recording this in the type itself. @@ -1830,67 +1848,92 @@ package body Sem_Ch13 is -- pragma is one of Convention/Import/Export. declare - P_Name : Name_Id; - A_Name : Name_Id; - A : Node_Id; - Arg_List : List_Id; - Found : Boolean; - L_Assoc : Node_Id; - E_Assoc : Node_Id; + 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 - P_Name := Chars (Id); - Found := False; - Arg_List := New_List; - L_Assoc := Empty; - E_Assoc := Empty; - - A := First (L); - while Present (A) loop - A_Name := Chars (Identifier (A)); - - if Nam_In (A_Name, Name_Import, Name_Export) then - if Found then - Error_Msg_N ("conflicting", A); + 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 - Found := True; + Imp_Exp_Seen := True; + + if Asp_Nam = Name_Import then + Imp_Seen := True; + end if; end if; - P_Name := A_Name; + Prag_Nam := Asp_Nam; + + -- Aspect External_Name adds an extra argument to the + -- generated pragma. - elsif A_Name = Name_Link_Name then - L_Assoc := + elsif Asp_Nam = Name_External_Name then + Extern_Arg := Make_Pragma_Argument_Association (Loc, - Chars => A_Name, - Expression => Relocate_Node (Expression (A))); + Chars => Asp_Nam, + Expression => Relocate_Node (Expression (Asp))); - elsif A_Name = Name_External_Name then - E_Assoc := + -- 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 => A_Name, - Expression => Relocate_Node (Expression (A))); + Chars => Asp_Nam, + Expression => Relocate_Node (Expression (Asp))); end if; - Next (A); + Next (Asp); end loop; - Arg_List := New_List ( - Make_Pragma_Argument_Association (Sloc (Expr), - Expression => Relocate_Node (Expr)), - Make_Pragma_Argument_Association (Sloc (Ent), - Expression => Ent)); + -- Assemble the full argument list - if Present (L_Assoc) then - Append_To (Arg_List, L_Assoc); + if Present (Extern_Arg) then + Append_To (Args, Extern_Arg); end if; - if Present (E_Assoc) then - Append_To (Arg_List, E_Assoc); + if Present (Link_Arg) then + Append_To (Args, Link_Arg); end if; Make_Aitem_Pragma - (Pragma_Argument_Associations => Arg_List, - Pragma_Name => P_Name); + (Pragma_Argument_Associations => Args, + Pragma_Name => Prag_Nam); + + -- Store the generated pragma Import in the related + -- subprogram. + + if Imp_Seen and then Is_Subprogram (E) then + Set_Import_Pragma (E, Aitem); + end if; end; -- CPU, Interrupt_Priority, Priority @@ -1931,7 +1974,7 @@ package body Sem_Ch13 is -- The expression must be static - elsif not Is_Static_Expression (Expr) then + elsif not Is_OK_Static_Expression (Expr) then Flag_Non_Static_Expr ("aspect requires static expression!", Expr); @@ -1994,13 +2037,12 @@ package body Sem_Ch13 is -- the supported profile) to make sure that one of these -- packages is implicitly with'ed, since we need to have -- the tasking run time active for the pragma Priority to - -- have any effect. Previously with with'ed the package + -- have any effect. Previously we with'ed the package -- System.Tasking, but this package does not trigger the -- required initialization of the run-time library. declare Discard : Entity_Id; - pragma Warnings (Off, Discard); begin if Restricted_Profile then Discard := RTE (RE_Activate_Restricted_Tasks); @@ -2111,7 +2153,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Abstract_State); - Decorate_Aspect_And_Pragma (Aspect, Aitem); + Decorate (Aspect, Aitem); Decls := Visible_Declarations (Specification (Context)); @@ -2168,12 +2210,34 @@ package body Sem_Ch13 is goto Continue; end Abstract_State; + -- Aspect Default_Internal_Condition is never delayed because + -- it is equivalent to a source pragma which appears after the + -- related private type. To deal with forward references, the + -- generated pragma is stored in the rep chain of the related + -- private type as types do not carry contracts. The pragma is + -- wrapped inside of a procedure at the freeze point of the + -- private type's full view. + + when Aspect_Default_Initial_Condition => + Make_Aitem_Pragma + (Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))), + Pragma_Name => + Name_Default_Initial_Condition); + + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); + goto Continue; + -- Depends - -- Aspect Depends must be delayed because it mentions names - -- of inputs and output that are classified by aspect Global. - -- The aspect and pragma are treated the same way as a post - -- condition. + -- Aspect Depends is never delayed because it is equivalent to + -- a source pragma which appears after the related subprogram. + -- To deal with forward references, the generated pragma is + -- stored in the contract of the related subprogram and later + -- analyzed at the end of the declarative region. See routine + -- Analyze_Depends_In_Decl_Part for details. when Aspect_Depends => Make_Aitem_Pragma @@ -2182,17 +2246,18 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Depends); - Decorate_Aspect_And_Pragma - (Aspect, Aitem, Delayed => True); - Insert_Delayed_Pragma (Aitem); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); goto Continue; -- Global - -- Aspect Global must be delayed because it can mention names - -- and benefit from the forward visibility rules applicable to - -- aspects of subprograms. The aspect and pragma are treated - -- the same way as a post condition. + -- Aspect Global is never delayed because it is equivalent to + -- a source pragma which appears after the related subprogram. + -- To deal with forward references, the generated pragma is + -- stored in the contract of the related subprogram and later + -- analyzed at the end of the declarative region. See routine + -- Analyze_Global_In_Decl_Part for details. when Aspect_Global => Make_Aitem_Pragma @@ -2201,25 +2266,28 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Global); - Decorate_Aspect_And_Pragma - (Aspect, Aitem, Delayed => True); - Insert_Delayed_Pragma (Aitem); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); goto Continue; -- Initial_Condition - -- Aspect Initial_Condition covers the visible declarations of - -- a package and all hidden states through functions. As such, - -- it must be evaluated at the end of the said declarations. + -- Aspect Initial_Condition is never delayed because it is + -- equivalent to a source pragma which appears after the + -- related package. To deal with forward references, the + -- generated pragma is stored in the contract of the related + -- package and later analyzed at the end of the declarative + -- region. See routine Analyze_Initial_Condition_In_Decl_Part + -- for details. when Aspect_Initial_Condition => Initial_Condition : declare Context : Node_Id := N; Decls : List_Id; begin - -- When aspect Abstract_State appears on a generic package, - -- it is propageted to the package instance. The context in - -- this case is the instance spec. + -- When aspect Initial_Condition appears on a generic + -- package, it is propageted to the package instance. The + -- context in this case is the instance spec. if Nkind (Context) = N_Package_Instantiation then Context := Instance_Spec (Context); @@ -2236,9 +2304,7 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Initial_Condition); - - Decorate_Aspect_And_Pragma - (Aspect, Aitem, Delayed => True); + Decorate (Aspect, Aitem); if No (Decls) then Decls := New_List; @@ -2266,9 +2332,12 @@ package body Sem_Ch13 is -- Initializes - -- Aspect Initializes coverts the visible declarations of a - -- package. As such, it must be evaluated at the end of the - -- said declarations. + -- Aspect Initializes is never delayed because it is equivalent + -- to a source pragma appearing after the related package. To + -- deal with forward references, the generated pragma is stored + -- in the contract of the related package and later analyzed at + -- the end of the declarative region. For details, see routine + -- Analyze_Initializes_In_Decl_Part. when Aspect_Initializes => Initializes : declare Context : Node_Id := N; @@ -2293,9 +2362,7 @@ package body Sem_Ch13 is Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Initializes); - - Decorate_Aspect_And_Pragma - (Aspect, Aitem, Delayed => True); + Decorate (Aspect, Aitem); if No (Decls) then Decls := New_List; @@ -2321,6 +2388,25 @@ package body Sem_Ch13 is goto Continue; end Initializes; + -- Obsolescent + + when Aspect_Obsolescent => declare + Args : List_Id; + + begin + if No (Expr) then + Args := No_List; + else + Args := New_List ( + Make_Pragma_Argument_Association (Sloc (Expr), + Expression => Relocate_Node (Expr))); + end if; + + Make_Aitem_Pragma + (Pragma_Argument_Associations => Args, + Pragma_Name => Chars (Id)); + end; + -- Part_Of when Aspect_Part_Of => @@ -2351,12 +2437,12 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_SPARK_Mode); - -- When the aspect appears on a package body, insert the - -- generated pragma at the top of the body declarations to - -- emulate the behavior of a source pragma. + -- When the aspect appears on a package or a subprogram + -- body, insert the generated pragma at the top of the body + -- declarations to emulate the behavior of a source pragma. - if Nkind (N) = N_Package_Body then - Decorate_Aspect_And_Pragma (Aspect, Aitem); + if Nkind_In (N, N_Package_Body, N_Subprogram_Body) then + Decorate (Aspect, Aitem); Decls := Declarations (N); @@ -2368,12 +2454,15 @@ package body Sem_Ch13 is Prepend_To (Decls, Aitem); goto Continue; - -- When the aspect is associated with package declaration, - -- insert the generated pragma at the top of the visible - -- declarations to emulate the behavior of a source pragma. + -- When the aspect is associated with a [generic] package + -- declaration, insert the generated pragma at the top of + -- the visible declarations to emulate the behavior of a + -- source pragma. - elsif Nkind (N) = N_Package_Declaration then - Decorate_Aspect_And_Pragma (Aspect, Aitem); + elsif Nkind_In (N, N_Generic_Package_Declaration, + N_Package_Declaration) + then + Decorate (Aspect, Aitem); Decls := Visible_Declarations (Specification (N)); @@ -2389,10 +2478,13 @@ package body Sem_Ch13 is -- Refined_Depends - -- Aspect Refined_Depends must be delayed because it can - -- mention state refinements introduced by aspect Refined_State - -- and further classified by aspect Refined_Global. Since both - -- those aspects are delayed, so is Refined_Depends. + -- Aspect Refined_Depends is never delayed because it is + -- equivalent to a source pragma which appears in the + -- declarations of the related subprogram body. To deal with + -- forward references, the generated pragma is stored in the + -- contract of the related subprogram body and later analyzed + -- at the end of the declarative region. For details, see + -- routine Analyze_Refined_Depends_In_Decl_Part. when Aspect_Refined_Depends => Make_Aitem_Pragma @@ -2401,17 +2493,19 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Refined_Depends); - Decorate_Aspect_And_Pragma - (Aspect, Aitem, Delayed => True); - Insert_Delayed_Pragma (Aitem); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); goto Continue; -- Refined_Global - -- Aspect Refined_Global must be delayed because it can mention - -- state refinements introduced by aspect Refined_State. Since - -- Refined_State is already delayed due to forward references, - -- so is Refined_Global. + -- Aspect Refined_Global is never delayed because it is + -- equivalent to a source pragma which appears in the + -- declarations of the related subprogram body. To deal with + -- forward references, the generated pragma is stored in the + -- contract of the related subprogram body and later analyzed + -- at the end of the declarative region. For details, see + -- routine Analyze_Refined_Global_In_Decl_Part. when Aspect_Refined_Global => Make_Aitem_Pragma @@ -2420,8 +2514,8 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Name_Refined_Global); - Decorate_Aspect_And_Pragma (Aspect, Aitem, Delayed => True); - Insert_Delayed_Pragma (Aitem); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); goto Continue; -- Refined_Post @@ -2436,7 +2530,6 @@ package body Sem_Ch13 is -- Refined_State when Aspect_Refined_State => Refined_State : declare - Decl : Node_Id; Decls : List_Id; begin @@ -2446,38 +2539,29 @@ package body Sem_Ch13 is -- the pragma. if Nkind (N) = N_Package_Body then + Decls := Declarations (N); + Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Loc, Expression => Relocate_Node (Expr))), Pragma_Name => Name_Refined_State); - Decorate_Aspect_And_Pragma (Aspect, Aitem); - - Decls := Declarations (N); + Decorate (Aspect, Aitem); - -- When the package body is subject to pragma SPARK_Mode, - -- insert pragma Refined_State after SPARK_Mode. - - if Present (Decls) then - Decl := First (Decls); - - if Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Name_SPARK_Mode - then - Insert_After (Decl, Aitem); - - -- The related package body lacks SPARK_Mode, the - -- corresponding pragma must be the first declaration. - - else - Prepend_To (Decls, Aitem); - end if; + if No (Decls) then + Decls := New_List; + Set_Declarations (N, Decls); + end if; - -- Otherwise the pragma forms a new declarative list + -- Pragma Refined_State must be inserted after pragma + -- SPARK_Mode in the tree. This ensures that any error + -- messages dependent on SPARK_Mode will be properly + -- enabled/suppressed. - else - Set_Declarations (N, New_List (Aitem)); - end if; + Insert_After_SPARK_Mode + (Prag => Aitem, + Ins_Nod => First (Decls), + Decls => Decls); else Error_Msg_NE @@ -2606,10 +2690,27 @@ package body Sem_Ch13 is -- Case 3a: The aspects listed below don't correspond to -- pragmas/attributes but do require delayed analysis. - -- Default_Value, Default_Component_Value + -- Default_Value can only apply to a scalar type + + when Aspect_Default_Value => + if not Is_Scalar_Type (E) then + Error_Msg_N + ("aspect Default_Value must apply to a scalar_Type", N); + end if; + + Aitem := Empty; + + -- Default_Component_Value can only apply to an array type + -- with scalar components. + + when Aspect_Default_Component_Value => + 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); + end if; - when Aspect_Default_Value | - Aspect_Default_Component_Value => Aitem := Empty; -- Case 3b: The aspects listed below don't correspond to @@ -2680,7 +2781,7 @@ package body Sem_Ch13 is -- or precondition error). -- We do not do this for Pre'Class, since we have to put - -- these conditions together in a complex OR expression + -- these conditions together in a complex OR expression. -- We do not do this in ASIS mode, as ASIS relies on the -- original node representing the complete expression, when @@ -2704,7 +2805,7 @@ package body Sem_Ch13 is -- Build the precondition/postcondition pragma - -- Add note about why we do NOT need Copy_Tree here ??? + -- Add note about why we do NOT need Copy_Tree here??? Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( @@ -2735,7 +2836,7 @@ package body Sem_Ch13 is -- about delay issues, since the pragmas themselves deal -- with delay of visibility for the expression analysis. - Insert_Delayed_Pragma (Aitem); + Insert_Pragma (Aitem); goto Continue; end Pre_Post; @@ -2764,9 +2865,9 @@ package body Sem_Ch13 is end if; -- Make pragma expressions refer to the original aspect - -- expressions through the Original_Node link. This is - -- used in semantic analysis for ASIS mode, so that the - -- original expression also gets analyzed. + -- expressions through the Original_Node link. This is used + -- in semantic analysis for ASIS mode, so that the original + -- expression also gets analyzed. Comp_Expr := First (Expressions (Expr)); while Present (Comp_Expr) loop @@ -2815,9 +2916,8 @@ package body Sem_Ch13 is Expression => Relocate_Node (Expr))), Pragma_Name => Nam); - Decorate_Aspect_And_Pragma - (Aspect, Aitem, Delayed => True); - Insert_Delayed_Pragma (Aitem); + Decorate (Aspect, Aitem); + Insert_Pragma (Aitem); goto Continue; -- Case 5: Special handling for aspects with an optional @@ -2874,12 +2974,43 @@ package body Sem_Ch13 is 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, + -- 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); + + -- 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; end if; @@ -2895,14 +3026,51 @@ package body Sem_Ch13 is and then Nkind (Parent (N)) /= N_Compilation_Unit then Error_Msg_N - ("incorrect context for library unit aspect&", Id); + ("incorrect context for library unit aspect&", Id); goto Continue; end if; - -- Cases where we do not delay, includes all cases where - -- the expression is missing other than the above cases. + -- External property aspects are Boolean by nature, but + -- their pragmas must contain two arguments, the second + -- being the optional Boolean expression. + + if A_Id = Aspect_Async_Readers or else + A_Id = Aspect_Async_Writers or else + A_Id = Aspect_Effective_Reads or else + A_Id = Aspect_Effective_Writes + then + declare + Args : List_Id; + + begin + -- The first argument of the external property pragma + -- is the related object. + + Args := + New_List ( + Make_Pragma_Argument_Association (Sloc (Ent), + Expression => Ent)); - if not Delay_Required or else No (Expr) then + -- The second argument is the optional Boolean + -- expression which must be propagated even if it + -- evaluates to False as this has special semantic + -- meaning. + + if Present (Expr) then + Append_To (Args, + Make_Pragma_Argument_Association (Loc, + Expression => Relocate_Node (Expr))); + end if; + + Make_Aitem_Pragma + (Pragma_Argument_Associations => Args, + Pragma_Name => Nam); + end; + + -- Cases where we do not delay, includes all cases where the + -- expression is missing other than the above cases. + + elsif not Delay_Required or else No (Expr) then Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( Make_Pragma_Argument_Association (Sloc (Ent), @@ -2912,7 +3080,7 @@ package body Sem_Ch13 is -- In general cases, the corresponding pragma/attribute -- definition clause will be inserted later at the freezing - -- point, and we do not need to build it now + -- point, and we do not need to build it now. else Aitem := Empty; @@ -2949,8 +3117,8 @@ package body Sem_Ch13 is End_Label => Empty)); end if; - -- Create a pragma and put it at the start of the - -- task definition for the task type declaration. + -- Create a pragma and put it at the start of the task + -- definition for the task type declaration. Make_Aitem_Pragma (Pragma_Argument_Associations => New_List ( @@ -2979,16 +3147,16 @@ package body Sem_Ch13 is -- the aspect specification node. if Present (Aitem) then - Set_From_Aspect_Specification (Aitem, True); + Set_From_Aspect_Specification (Aitem); end if; -- In the context of a compilation unit, we directly put the -- pragma in the Pragmas_After list of the N_Compilation_Unit_Aux -- node (no delay is required here) except for aspects on a - -- subprogram body (see below) and a generic package, for which - -- we need to introduce the pragma before building the generic - -- copy (see sem_ch12), and for package instantiations, where - -- the library unit pragmas are better handled early. + -- subprogram body (see below) and a generic package, for which we + -- need to introduce the pragma before building the generic copy + -- (see sem_ch12), and for package instantiations, where the + -- library unit pragmas are better handled early. if Nkind (Parent (N)) = N_Compilation_Unit and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect)) @@ -3185,12 +3353,12 @@ package body Sem_Ch13 is FOnly : Boolean := False; -- Reset to True for subtype specific attribute (Alignment, Size) - -- and for stream attributes, i.e. those cases where in the call - -- to Rep_Item_Too_Late, FOnly is set True so that only the freezing - -- rules are checked. Note that the case of stream attributes is not - -- clear from the RM, but see AI95-00137. Also, the RM seems to - -- disallow Storage_Size for derived task types, but that is also - -- clearly unintentional. + -- and for stream attributes, i.e. those cases where in the call to + -- Rep_Item_Too_Late, FOnly is set True so that only the freezing rules + -- are checked. Note that the case of stream attributes is not clear + -- from the RM, but see AI95-00137. Also, the RM seems to disallow + -- Storage_Size for derived task types, but that is also clearly + -- unintentional. procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type); -- Common processing for 'Read, 'Write, 'Input and 'Output attribute @@ -3272,12 +3440,23 @@ package body Sem_Ch13 is Typ := Etype (F); + -- If the attribute specification comes from an aspect + -- specification for a class-wide stream, the parameter must be + -- a class-wide type of the entity to which the aspect applies. + + if From_Aspect_Specification (N) + and then Class_Present (Parent (N)) + and then Is_Class_Wide_Type (Typ) + then + Typ := Etype (Typ); + end if; + else Typ := Etype (Subp); end if; - -- Verify that the prefix of the attribute and the local name - -- for the type of the formal match. + -- Verify that the prefix of the attribute and the local name for + -- the type of the formal match. if Base_Type (Typ) /= Base_Type (Ent) or else Present ((Next_Formal (F))) @@ -3389,59 +3568,183 @@ package body Sem_Ch13 is ------------------------------ procedure Check_Indexing_Functions is - Indexing_Found : Boolean; + Indexing_Found : Boolean := False; procedure Check_One_Function (Subp : Entity_Id); - -- Check one possible interpretation. Sets Indexing_Found True if an - -- indexing function is found. + -- Check one possible interpretation. Sets Indexing_Found True if a + -- legal indexing function is found. + + procedure Illegal_Indexing (Msg : String); + -- Diagnose illegal indexing function if not overloaded. In the + -- overloaded case indicate that no legal interpretation exists. ------------------------ -- Check_One_Function -- ------------------------ procedure Check_One_Function (Subp : Entity_Id) is - Default_Element : constant Node_Id := - Find_Value_Of_Aspect - (Etype (First_Formal (Subp)), - Aspect_Iterator_Element); + Default_Element : Node_Id; + Ret_Type : constant Entity_Id := Etype (Subp); begin + if not Is_Overloadable (Subp) then + Illegal_Indexing ("illegal indexing function for type&"); + return; + + elsif Scope (Subp) /= Scope (Ent) then + if Nkind (Expr) = N_Expanded_Name then + + -- Indexing function can't be declared elsewhere + + Illegal_Indexing + ("indexing function must be declared in scope of type&"); + end if; + + return; + + elsif No (First_Formal (Subp)) then + Illegal_Indexing + ("Indexing requires a function that applies to type&"); + return; + + elsif No (Next_Formal (First_Formal (Subp))) then + Illegal_Indexing + ("indexing function must have at least two parameters"); + return; + + elsif Is_Derived_Type (Ent) then + if (Attr = Name_Constant_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Constant_Indexing))) + + or else (Attr = Name_Variable_Indexing + and then Present + (Find_Aspect (Etype (Ent), Aspect_Variable_Indexing))) + then + if Debug_Flag_Dot_XX then + null; + + else + Illegal_Indexing + ("indexing function already inherited " + & "from parent type"); + return; + end if; + end if; + end if; + if not Check_Primitive_Function (Subp) - and then not Is_Overloaded (Expr) then - Error_Msg_NE - ("aspect Indexing requires a function that applies to type&", - Subp, Ent); + Illegal_Indexing + ("Indexing aspect requires a function that applies to type&"); + return; + end if; + + -- If partial declaration exists, verify that it is not tagged. + + if Ekind (Current_Scope) = E_Package + and then Has_Private_Declaration (Ent) + and then From_Aspect_Specification (N) + and then + List_Containing (Parent (Ent)) = + Private_Declarations + (Specification (Unit_Declaration_Node (Current_Scope))) + and then Nkind (N) = N_Attribute_Definition_Clause + then + declare + Decl : Node_Id; + + begin + Decl := + First (Visible_Declarations + (Specification + (Unit_Declaration_Node (Current_Scope)))); + + while Present (Decl) loop + if Nkind (Decl) = N_Private_Type_Declaration + and then Ent = Full_View (Defining_Identifier (Decl)) + and then Tagged_Present (Decl) + and then No (Aspect_Specifications (Decl)) + then + Illegal_Indexing + ("Indexing aspect cannot be specified on full view " + & "if partial view is tagged"); + return; + end if; + + Next (Decl); + end loop; + end; end if; -- An indexing function must return either the default element of -- the container, or a reference type. For variable indexing it -- must be the latter. + Default_Element := + Find_Value_Of_Aspect + (Etype (First_Formal (Subp)), Aspect_Iterator_Element); + if Present (Default_Element) then Analyze (Default_Element); if Is_Entity_Name (Default_Element) - and then Covers (Entity (Default_Element), Etype (Subp)) + and then not Covers (Entity (Default_Element), Ret_Type) + and then False then - Indexing_Found := True; + Illegal_Indexing + ("wrong return type for indexing function"); return; end if; end if; -- For variable_indexing the return type must be a reference type - if Attr = Name_Variable_Indexing - and then not Has_Implicit_Dereference (Etype (Subp)) - then - Error_Msg_N - ("function for indexing must return a reference type", Subp); + if Attr = Name_Variable_Indexing then + if not Has_Implicit_Dereference (Ret_Type) then + Illegal_Indexing + ("variable indexing must return a reference type"); + return; + + elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) + then + Illegal_Indexing + ("variable indexing must return an access to variable"); + return; + end if; else - Indexing_Found := True; + if Has_Implicit_Dereference (Ret_Type) + and then not + Is_Access_Constant (Etype (First_Discriminant (Ret_Type))) + then + Illegal_Indexing + ("constant indexing must return an access to constant"); + return; + + elsif Is_Access_Type (Etype (First_Formal (Subp))) + and then not Is_Access_Constant (Etype (First_Formal (Subp))) + then + Illegal_Indexing + ("constant indexing must apply to an access to constant"); + return; + end if; end if; + + -- All checks succeeded. + + Indexing_Found := True; end Check_One_Function; + ----------------------- + -- Illegal_Indexing -- + ----------------------- + + procedure Illegal_Indexing (Msg : String) is + begin + Error_Msg_NE (Msg, N, Ent); + end Illegal_Indexing; + -- Start of processing for Check_Indexing_Functions begin @@ -3474,14 +3777,14 @@ package body Sem_Ch13 is Get_Next_Interp (I, It); end loop; - - if not Indexing_Found then - Error_Msg_NE - ("aspect Indexing requires a function that " - & "applies to type&", Expr, Ent); - end if; end; end if; + + if not Indexing_Found and then not Error_Posted (N) then + Error_Msg_NE + ("aspect Indexing requires a local function that " + & "applies to type&", Expr, Ent); + end if; end Check_Indexing_Functions; ------------------------------ @@ -3649,8 +3952,8 @@ package body Sem_Ch13 is begin -- The following code is a defense against recursion. Not clear that - -- this can happen legitimately, but perhaps some error situations - -- can cause it, and we did see this recursion during testing. + -- this can happen legitimately, but perhaps some error situations can + -- cause it, and we did see this recursion during testing. if Analyzed (N) then return; @@ -3700,10 +4003,10 @@ package body Sem_Ch13 is return; -- The following should not be ignored, because in the first place - -- they are reasonably portable, and should not cause problems in - -- compiling code from another target, and also they do affect - -- legality, e.g. failing to provide a stream attribute for a - -- type may make a program illegal. + -- they are reasonably portable, and should not cause problems + -- in compiling code from another target, and also they do affect + -- legality, e.g. failing to provide a stream attribute for a type + -- may make a program illegal. when Attribute_External_Tag | Attribute_Input | @@ -4227,13 +4530,13 @@ package body Sem_Ch13 is if Etype (Expr) = Any_Type then return; - elsif not Is_Static_Expression (Expr) then + elsif not Is_OK_Static_Expression (Expr) then Flag_Non_Static_Expr ("Bit_Order requires static expression!", Expr); else if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then - Set_Reverse_Bit_Order (U_Ent, True); + Set_Reverse_Bit_Order (Base_Type (U_Ent), True); end if; end if; end if; @@ -4367,7 +4670,7 @@ package body Sem_Ch13 is Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range)); Uninstall_Discriminants_And_Pop_Scope (U_Ent); - if not Is_Static_Expression (Expr) then + if not Is_OK_Static_Expression (Expr) then Check_Restriction (Static_Priorities, Expr); end if; end if; @@ -4466,7 +4769,7 @@ package body Sem_Ch13 is else Analyze_And_Resolve (Expr, Standard_String); - if not Is_Static_Expression (Expr) then + if not Is_OK_Static_Expression (Expr) then Flag_Non_Static_Expr ("static string required for tag name!", Nam); end if; @@ -4700,7 +5003,7 @@ package body Sem_Ch13 is Preanalyze_Spec_Expression (Expr, Standard_Integer); Uninstall_Discriminants_And_Pop_Scope (U_Ent); - if not Is_Static_Expression (Expr) then + if not Is_OK_Static_Expression (Expr) then Check_Restriction (Static_Priorities, Expr); end if; end if; @@ -4741,7 +5044,7 @@ package body Sem_Ch13 is if Etype (Expr) = Any_Type then return; - elsif not Is_Static_Expression (Expr) then + elsif not Is_OK_Static_Expression (Expr) then Flag_Non_Static_Expr ("Scalar_Storage_Order requires static expression!", Expr); @@ -4758,6 +5061,12 @@ package body Sem_Ch13 is & "not supported on target", Expr); end if; end if; + + -- Clear SSO default indications since explicit setting of the + -- order overrides the defaults. + + 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; @@ -4896,7 +5205,7 @@ package body Sem_Ch13 is if Etype (Expr) = Any_Type then return; - elsif not Is_Static_Expression (Expr) then + elsif not Is_OK_Static_Expression (Expr) then Flag_Non_Static_Expr ("small requires static expression!", Expr); return; @@ -5567,7 +5876,7 @@ package body Sem_Ch13 is -- ??? should allow static subtype with zero/one entry elsif Etype (Choice) = Base_Type (Enumtype) then - if not Is_Static_Expression (Choice) then + if not Is_OK_Static_Expression (Choice) then Flag_Non_Static_Expr ("non-static expression used for choice!", Choice); Err := True; @@ -6266,13 +6575,13 @@ package body Sem_Ch13 is function Build_Val (V : Uint) return Node_Id; -- Return an analyzed N_Identifier node referencing this value, suitable - -- for use as an entry in the Static_Predicate list. This node is typed - -- with the base type. + -- for use as an entry in the Static_Discrte_Predicate list. This node + -- is typed with the base type. function Build_Range (Lo : Uint; Hi : Uint) return Node_Id; -- Return an analyzed N_Range node referencing this range, suitable for - -- use as an entry in the Static_Predicate list. This node is typed with - -- the base type. + -- use as an entry in the Static_Discrete_Predicate list. This node is + -- typed with the base type. function Get_RList (Exp : Node_Id) return RList; -- This is a recursive routine that converts the given expression into a @@ -6295,12 +6604,14 @@ package body Sem_Ch13 is -- name appears in parens, this routine will return False. function Lo_Val (N : Node_Id) return Uint; - -- Given static expression or static range from a Static_Predicate list, - -- gets expression value or low bound of range. + -- Given an entry from a Static_Discrete_Predicate list that is either + -- a static expression or static range, gets either the expression value + -- or the low bound of the range. function Hi_Val (N : Node_Id) return Uint; - -- Given static expression or static range from a Static_Predicate list, - -- gets expression value of high bound of range. + -- Given an entry from a Static_Discrete_Predicate list that is either + -- a static expression or static range, gets either the expression value + -- or the high bound of the range. function Membership_Entry (N : Node_Id) return RList; -- Given a single membership entry (range, value, or subtype), returns @@ -6737,7 +7048,7 @@ package body Sem_Ch13 is while Present (Alt) loop Dep := Expression (Alt); - if not Is_Static_Expression (Dep) then + if not Is_OK_Static_Expression (Dep) then raise Non_Static; elsif Is_True (Expr_Value (Dep)) then @@ -6781,7 +7092,7 @@ package body Sem_Ch13 is function Hi_Val (N : Node_Id) return Uint is begin - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then return Expr_Value (N); else pragma Assert (Nkind (N) = N_Range); @@ -6826,7 +7137,7 @@ package body Sem_Ch13 is function Lo_Val (N : Node_Id) return Uint is begin - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then return Expr_Value (N); else pragma Assert (Nkind (N) = N_Range); @@ -6860,9 +7171,9 @@ package body Sem_Ch13 is -- Range case if Nkind (N) = N_Range then - if not Is_Static_Expression (Low_Bound (N)) + if not Is_OK_Static_Expression (Low_Bound (N)) or else - not Is_Static_Expression (High_Bound (N)) + not Is_OK_Static_Expression (High_Bound (N)) then raise Non_Static; else @@ -6873,7 +7184,7 @@ package body Sem_Ch13 is -- Static expression case - elsif Is_Static_Expression (N) then + elsif Is_OK_Static_Expression (N) then Val := Expr_Value (N); return RList'(1 => REnt'(Val, Val)); @@ -6892,7 +7203,7 @@ package body Sem_Ch13 is -- For static subtype without predicates, get range - elsif Is_Static_Subtype (Entity (N)) then + elsif Is_OK_Static_Subtype (Entity (N)) then SLo := Expr_Value (Type_Low_Bound (Entity (N))); SHi := Expr_Value (Type_High_Bound (Entity (N))); return RList'(1 => REnt'(SLo, SHi)); @@ -6920,18 +7231,19 @@ package body Sem_Ch13 is begin -- Not static if type does not have static predicates - if not Has_Predicates (Typ) or else No (Static_Predicate (Typ)) then + if not Has_Static_Predicate (Typ) then raise Non_Static; end if; -- Otherwise we convert the predicate list to a range list declare - Result : RList (1 .. List_Length (Static_Predicate (Typ))); + Spred : constant List_Id := Static_Discrete_Predicate (Typ); + Result : RList (1 .. List_Length (Spred)); P : Node_Id; begin - P := First (Static_Predicate (Typ)); + P := First (Static_Discrete_Predicate (Typ)); for J in Result'Range loop Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); Next (P); @@ -6999,7 +7311,7 @@ package body Sem_Ch13 is -- Processing was successful and all entries were static, so now we -- can store the result as the predicate list. - Set_Static_Predicate (Typ, Plist); + Set_Static_Discrete_Predicate (Typ, Plist); -- The processing for static predicates put the expression into -- canonical form as a series of ranges. It also eliminated @@ -7400,8 +7712,23 @@ package body Sem_Ch13 is SId := Invariant_Procedure (Typ); end if; + -- 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. + + -- See Exp_Ch3.Insert_Component_Invariant_Checks for details. + if Present (SId) then PDecl := Unit_Declaration_Node (SId); + + if Present (PDecl) + and then Nkind (PDecl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (PDecl)) + then + return; + end if; + else PDecl := Build_Invariant_Procedure_Declaration (Typ); end if; @@ -7539,7 +7866,7 @@ package body Sem_Ch13 is Object_Name : constant Name_Id := New_Internal_Name ('I'); -- Name for argument of Predicate procedure. Note that we use the same - -- name for both predicate procedure. That way the reference within the + -- name for both predicate functions. That way the reference within the -- predicate expression is the same in both functions. Object_Entity : constant Entity_Id := @@ -7999,10 +8326,16 @@ package body Sem_Ch13 is -- yes even if we have an explicit Dynamic_Predicate present. declare - PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name); + PS : Boolean; EN : Node_Id; begin + if not Is_Scalar_Type (Typ) and then not Is_String_Type (Typ) then + PS := False; + else + PS := Is_Predicate_Static (Expr, Object_Name); + end if; + -- Case where we have a predicate-static aspect if PS then @@ -8018,6 +8351,15 @@ package body Sem_Ch13 is -- For discrete subtype, build the static predicate list if Is_Discrete_Type (Typ) then + if not Is_Static_Subtype (Typ) then + + -- This can only happen in the presence of previous + -- semantic errors. + + pragma Assert (Serious_Errors_Detected > 0); + return; + end if; + Build_Discrete_Static_Predicate (Typ, Expr, Object_Name); -- If we don't get a static predicate list, it means that we @@ -8027,9 +8369,14 @@ package body Sem_Ch13 is -- dynamic. But if we do succeed in building the list, then -- we mark the predicate as static. - if No (Static_Predicate (Typ)) then + if No (Static_Discrete_Predicate (Typ)) then Set_Has_Static_Predicate (Typ, False); end if; + + -- For real or string subtype, save predicate expression + + elsif Is_Real_Type (Typ) or else Is_String_Type (Typ) then + Set_Static_Real_Or_String_Predicate (Typ, Expr); end if; -- Case of dynamic predicate (expression is not predicate-static) @@ -8057,14 +8404,13 @@ package body Sem_Ch13 is -- Now post appropriate message if Has_Static_Predicate_Aspect (Typ) then - if Is_Scalar_Type (Typ) then + if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then Error_Msg_F - ("expression is not predicate-static (RM 4.3.2(16-22))", + ("expression is not predicate-static (RM 3.2.4(16-22))", EN); else - Error_Msg_FE - ("static predicate not allowed for non-scalar type&", - EN, Typ); + Error_Msg_F + ("static predicate requires scalar or string type", EN); end if; end if; end if; @@ -8422,25 +8768,27 @@ package body Sem_Ch13 is -- Here is the list of aspects that don't require delay analysis - when Aspect_Abstract_State | - Aspect_Annotate | - Aspect_Contract_Cases | - Aspect_Dimension | - Aspect_Dimension_System | - Aspect_Implicit_Dereference | - Aspect_Initial_Condition | - Aspect_Initializes | - 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 => + when Aspect_Abstract_State | + Aspect_Annotate | + Aspect_Contract_Cases | + Aspect_Default_Initial_Condition | + Aspect_Dimension | + Aspect_Dimension_System | + 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 => raise Program_Error; end case; @@ -9606,7 +9954,7 @@ package body Sem_Ch13 is -- issued elsewhere, since sizes of non-static array types -- cannot be set implicitly or explicitly. - if not Is_Static_Subtype (Ityp) then + if not Is_OK_Static_Subtype (Ityp) then return; end if; @@ -9684,6 +10032,130 @@ package body Sem_Ch13 is -------------------------- procedure Freeze_Entity_Checks (N : Node_Id) is + procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id); + -- Inspect the primitive operations of type Typ and hide all pairs of + -- implicitly declared non-overridden non-fully conformant homographs + -- (Ada RM 8.3 12.3/2). + + ------------------------------------- + -- Hide_Non_Overridden_Subprograms -- + ------------------------------------- + + procedure Hide_Non_Overridden_Subprograms (Typ : Entity_Id) is + procedure Hide_Matching_Homographs + (Subp_Id : Entity_Id; + Start_Elmt : Elmt_Id); + -- Inspect a list of primitive operations starting with Start_Elmt + -- and find matching implicitly declared non-overridden non-fully + -- conformant homographs of Subp_Id. If found, all matches along + -- with Subp_Id are hidden from all visibility. + + function Is_Non_Overridden_Or_Null_Procedure + (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is implicitly declared non- + -- overridden subprogram or an implicitly declared null procedure. + + ------------------------------ + -- Hide_Matching_Homographs -- + ------------------------------ + + procedure Hide_Matching_Homographs + (Subp_Id : Entity_Id; + Start_Elmt : Elmt_Id) + is + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + begin + Prim_Elmt := Start_Elmt; + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + + -- The current primitive is implicitly declared non-overridden + -- non-fully conformant homograph of Subp_Id. Both subprograms + -- must be hidden from visibility. + + if Chars (Prim) = Chars (Subp_Id) + and then Is_Non_Overridden_Or_Null_Procedure (Prim) + and then not Fully_Conformant (Prim, Subp_Id) + then + Set_Is_Hidden_Non_Overridden_Subpgm (Prim); + Set_Is_Immediately_Visible (Prim, False); + Set_Is_Potentially_Use_Visible (Prim, False); + + Set_Is_Hidden_Non_Overridden_Subpgm (Subp_Id); + Set_Is_Immediately_Visible (Subp_Id, False); + Set_Is_Potentially_Use_Visible (Subp_Id, False); + end if; + + Next_Elmt (Prim_Elmt); + end loop; + end Hide_Matching_Homographs; + + ----------------------------------------- + -- Is_Non_Overridden_Or_Null_Procedure -- + ----------------------------------------- + + function Is_Non_Overridden_Or_Null_Procedure + (Subp_Id : Entity_Id) return Boolean + is + Alias_Id : Entity_Id; + + begin + -- The subprogram is inherited (implicitly declared), it does not + -- override and does not cover a primitive of an interface. + + if Ekind_In (Subp_Id, E_Function, E_Procedure) + and then Present (Alias (Subp_Id)) + and then No (Interface_Alias (Subp_Id)) + and then No (Overridden_Operation (Subp_Id)) + then + Alias_Id := Alias (Subp_Id); + + if Requires_Overriding (Alias_Id) then + return True; + + elsif Nkind (Parent (Alias_Id)) = N_Procedure_Specification + and then Null_Present (Parent (Alias_Id)) + then + return True; + end if; + end if; + + return False; + end Is_Non_Overridden_Or_Null_Procedure; + + -- Local variables + + Prim_Ops : constant Elist_Id := Direct_Primitive_Operations (Typ); + Prim : Entity_Id; + Prim_Elmt : Elmt_Id; + + -- Start of processing for Hide_Non_Overridden_Subprograms + + begin + -- Inspect the list of primitives looking for non-overridden + -- subprograms. + + if Present (Prim_Ops) then + Prim_Elmt := First_Elmt (Prim_Ops); + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Next_Elmt (Prim_Elmt); + + if Is_Non_Overridden_Or_Null_Procedure (Prim) then + Hide_Matching_Homographs + (Subp_Id => Prim, + Start_Elmt => Prim_Elmt); + end if; + end loop; + end if; + end Hide_Non_Overridden_Subprograms; + + --------------------- + -- Local variables -- + --------------------- + E : constant Entity_Id := Entity (N); Non_Generic_Case : constant Boolean := Nkind (N) = N_Freeze_Entity; @@ -9691,6 +10163,9 @@ package body Sem_Ch13 is -- for the generic case since it is not needed. Basically in the -- generic case, we only need to do stuff that might generate error -- messages or warnings. + + -- Start of processing for Freeze_Entity_Checks + begin -- Remember that we are processing a freezing entity. Required to -- ensure correct decoration of internal entities associated with @@ -9726,6 +10201,18 @@ package body Sem_Ch13 is Add_Internal_Interface_Entities (E); end if; + -- 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). + + if Is_Tagged_Type (E) then + Hide_Non_Overridden_Subprograms (E); + end if; + -- Check CPP types if Ekind (E) = E_Record_Type @@ -9882,7 +10369,7 @@ package body Sem_Ch13 is end if; -- For a record type, deal with variant parts. This has to be delayed - -- to this point, because of the issue of statically precicated + -- to this point, because of the issue of statically predicated -- subtypes, which we have to ensure are frozen before checking -- choices, since we need to have the static choice list set. @@ -10101,9 +10588,10 @@ package body Sem_Ch13 is (Rep_Item : Node_Id) return Boolean is begin - return Nkind (Rep_Item) = N_Pragma - or else Present_In_Rep_Item - (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); + return + Nkind (Rep_Item) = N_Pragma + or else Present_In_Rep_Item + (Entity (Rep_Item), Aspect_Rep_Item (Rep_Item)); end Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item; -- Start of processing for Inherit_Aspects_At_Freeze_Point @@ -10298,6 +10786,12 @@ package body Sem_Ch13 is Set_Reverse_Storage_Order (Bas_Typ, Reverse_Storage_Order (Entity (Name (Get_Rep_Item (Typ, Name_Scalar_Storage_Order))))); + + -- Clear default SSO indications, since the inherited aspect + -- which was set explicitly overrides the default. + + Set_SSO_Set_Low_By_Default (Bas_Typ, False); + Set_SSO_Set_High_By_Default (Bas_Typ, False); end if; end if; end; @@ -10359,19 +10853,24 @@ package body Sem_Ch13 is -- Is_Predicate_Static -- ------------------------- + -- Note: the basic legality of the expression has already been checked, so + -- we don't need to worry about cases or ranges on strings for example. + function Is_Predicate_Static (Expr : Node_Id; Nam : Name_Id) return Boolean is function All_Static_Case_Alternatives (L : List_Id) return Boolean; - -- Given a list of case expression alternatives, returns True if - -- all the alternatives are static (have all static choices, and a - -- static expression). + -- Given a list of case expression alternatives, returns True if all + -- the alternatives are static (have all static choices, and a static + -- expression). function All_Static_Choices (L : List_Id) return Boolean; -- Returns true if all elements of the list are OK static choices -- as defined below for Is_Static_Choice. Used for case expression - -- alternatives and for the right operand of a membership test. + -- alternatives and for the right operand of a membership test. An + -- others_choice is static if the corresponding expression is static. + -- The staticness of the bounds is checked separately. function Is_Static_Choice (N : Node_Id) return Boolean; -- Returns True if N represents a static choice (static subtype, or @@ -10384,10 +10883,10 @@ package body Sem_Ch13 is function Is_Type_Ref (N : Node_Id) return Boolean; pragma Inline (Is_Type_Ref); - -- Returns True if N is a reference to the type for the predicate in - -- the 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. + -- Returns True if N is a reference to the type for the predicate in the + -- 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. ---------------------------------- -- All_Static_Case_Alternatives -- @@ -10437,7 +10936,8 @@ package body Sem_Ch13 is function Is_Static_Choice (N : Node_Id) return Boolean is begin - return Is_OK_Static_Expression (N) + return Nkind (N) = N_Others_Choice + or else Is_OK_Static_Expression (N) or else (Is_Entity_Name (N) and then Is_Type (Entity (N)) and then Is_OK_Static_Subtype (Entity (N))) or else (Nkind (N) = N_Subtype_Indication @@ -10459,12 +10959,6 @@ package body Sem_Ch13 is -- Start of processing for Is_Predicate_Static begin - -- Only scalar types can be predicate-static - - if not Is_Scalar_Type (Etype (Expr)) then - return False; - end if; - -- Predicate_Static means one of the following holds. Numbers are the -- corresponding paragraph numbers in (RM 3.2.4(16-22)). @@ -10499,7 +10993,20 @@ package body Sem_Ch13 is -- operand is the current instance, and the other is a static -- expression. + -- Note: the RM is clearly wrong here in not excluding string types. + -- Without this exclusion, we would allow expressions like X > "ABC" + -- to be considered as predicate-static, which is clearly not intended, + -- since the idea is for predicate-static to be a subset of normal + -- static expressions (and "DEF" > "ABC" is not a static expression). + + -- However, we do allow internally generated (not from source) equality + -- and inequality operations to be valid on strings (this helps deal + -- with cases where we transform A in "ABC" to A = "ABC). + 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 @@ -10534,7 +11041,7 @@ package body Sem_Ch13 is -- all the cases above. -- One more test that is an implementation artifact caused by the fact - -- that we are analyzing not the original expresesion, but the generated + -- that we are analyzing not the original expression, but the generated -- expression in the body of the predicate function. This can include -- references to inherited predicates, so that the expression we are -- processing looks like: @@ -10543,7 +11050,7 @@ package body Sem_Ch13 is -- Where the call is to a Predicate function for an inherited predicate. -- We simply ignore such a call (which could be to either a dynamic or - -- a static predicate, but remember that we can have Static_Predicate + -- a static predicate, but remember that we can have a Static_Predicate -- for a non-static subtype). elsif Nkind (Expr) = N_Function_Call @@ -10615,19 +11122,10 @@ package body Sem_Ch13 is then return 0; - -- Access types. Normally an access type cannot have a size smaller - -- than the size of System.Address. The exception is on VMS, where - -- we have short and long addresses, and it is possible for an access - -- type to have a short address size (and thus be less than the size - -- of System.Address itself). We simply skip the check for VMS, and - -- leave it to the back end to do the check. + -- Access types (cannot have size smaller than System.Address) elsif Is_Access_Type (T) then - if OpenVMS_On_Target then - return 0; - else - return System_Address_Size; - end if; + return System_Address_Size; -- Floating-point types @@ -11011,10 +11509,28 @@ package body Sem_Ch13 is S : Entity_Id; Parent_Type : Entity_Id; + procedure No_Type_Rep_Item; + -- Output message indicating that no type-related aspects can be + -- specified due to some property of the parent type. + procedure Too_Late; - -- Output the too late message. Note that this is not considered a - -- serious error, since the effect is simply that we ignore the - -- representation clause in this case. + -- Output message for an aspect being specified too late + + -- Note that neither of the above errors is considered a serious one, + -- since the effect is simply that we ignore the representation clause + -- in these cases. + -- Is this really true? In any case if we make this change we must + -- document the requirement in the spec of Rep_Item_Too_Late that + -- if True is returned, then the rep item must be completely ignored??? + + ---------------------- + -- No_Type_Rep_Item -- + ---------------------- + + procedure No_Type_Rep_Item is + begin + Error_Msg_N ("|type-related representation item not permitted!", N); + end No_Type_Rep_Item; -------------- -- Too_Late -- @@ -11054,14 +11570,18 @@ package body Sem_Ch13 is S := First_Subtype (T); if Present (Freeze_Node (S)) then - Error_Msg_NE - ("??no more representation items for }", Freeze_Node (S), S); + if not Relaxed_RM_Semantics then + Error_Msg_NE + ("??no more representation items for }", Freeze_Node (S), S); + end if; end if; return True; - -- Check for case of non-tagged derived type whose parent either has - -- primitive operations, or is a by reference type (RM 13.1(10)). + -- Check for case of untagged derived type whose parent either has + -- primitive operations, or is a by reference type (RM 13.1(10)). In + -- this case we do not output a Too_Late message, since there is no + -- earlier point where the rep item could be placed to make it legal. elsif Is_Type (T) and then not FOnly @@ -11071,19 +11591,69 @@ package body Sem_Ch13 is Parent_Type := Etype (Base_Type (T)); if Has_Primitive_Operations (Parent_Type) then - Too_Late; - Error_Msg_NE - ("primitive operations already defined for&!", N, Parent_Type); + No_Type_Rep_Item; + + if not Relaxed_RM_Semantics then + Error_Msg_NE + ("\parent type & has primitive operations!", N, Parent_Type); + end if; + return True; elsif Is_By_Reference_Type (Parent_Type) then - Too_Late; - Error_Msg_NE - ("parent type & is a by reference type!", N, Parent_Type); + No_Type_Rep_Item; + + if not Relaxed_RM_Semantics then + Error_Msg_NE + ("\parent type & is a by reference type!", N, Parent_Type); + end if; + return True; end if; end if; + -- No error, but one more warning to consider. The RM (surprisingly) + -- allows this pattern: + + -- type S is ... + -- primitive operations for S + -- type R is new S; + -- rep clause for S + + -- Meaning that calls on the primitive operations of S for values of + -- type R may require possibly expensive implicit conversion operations. + -- This is not an error, but is worth a warning. + + if not Relaxed_RM_Semantics and then Is_Type (T) then + declare + DTL : constant Entity_Id := Derived_Type_Link (Base_Type (T)); + + begin + if Present (DTL) + and then Has_Primitive_Operations (Base_Type (T)) + + -- For now, do not generate this warning for the case of aspect + -- specification using Ada 2012 syntax, since we get wrong + -- messages we do not understand. The whole business of derived + -- types and rep items seems a bit confused when aspects are + -- used, since the aspects are not evaluated till freeze time. + + and then not From_Aspect_Specification (N) + then + Error_Msg_Sloc := Sloc (DTL); + Error_Msg_N + ("representation item for& appears after derived type " + & "declaration#??", N); + Error_Msg_NE + ("\may result in implicit conversions for primitive " + & "operations of&??", N, T); + Error_Msg_NE + ("\to change representations when called with arguments " + & "of type&??", N, DTL); + end if; + end; + end if; + -- No error, link item into head of chain of rep items for the entity, -- but avoid chaining if we have an overloadable entity, and the pragma -- is one that can apply to multiple overloaded entities. @@ -11210,7 +11780,7 @@ package body Sem_Ch13 is end loop; end if; - -- Continue for any other node kind + -- Continue for any other node kind else return OK; @@ -11869,11 +12439,24 @@ package body Sem_Ch13 is return; end if; + -- Case of component size is greater than or equal to 64 and the + -- alignment of the array is at least as large as the alignment + -- of the component. We are definitely OK in this situation. + + if Known_Component_Size (Atyp) + and then Component_Size (Atyp) >= 64 + and then Known_Alignment (Atyp) + and then Known_Alignment (Ctyp) + and then Alignment (Atyp) >= Alignment (Ctyp) + then + return; + end if; + -- Check actual component size if not Known_Component_Size (Atyp) or else not (Addressable (Component_Size (Atyp)) - and then Component_Size (Atyp) < 64) + and then Component_Size (Atyp) < 64) or else Component_Size (Atyp) mod Esize (Ctyp) /= 0 then No_Independence; @@ -12243,13 +12826,10 @@ package body Sem_Ch13 is and then Convention (Target) /= Convention (Source) and then Warn_On_Unchecked_Conversion then - -- Give warnings for subprogram pointers only on most targets. The - -- exception is VMS, where data pointers can have different lengths - -- depending on the pointer convention. + -- Give warnings for subprogram pointers only on most targets if Is_Access_Subprogram_Type (Target) or else Is_Access_Subprogram_Type (Source) - or else OpenVMS_On_Target then Error_Msg_N ("?z?conversion between pointers with different conventions!", diff --git a/main/gcc/ada/sem_ch13.ads b/main/gcc/ada/sem_ch13.ads index f666a3f1b43..b1bb1592b45 100644 --- a/main/gcc/ada/sem_ch13.ads +++ b/main/gcc/ada/sem_ch13.ads @@ -144,6 +144,17 @@ package Sem_Ch13 is -- type. Returns False if no such error occurs. If this error does occur, -- appropriate error messages are posted on node N, and True is returned. + generic + with procedure Replace_Type_Reference (N : Node_Id); + procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id); + -- This is used to scan an expression for a predicate or invariant aspect + -- replacing occurrences of the name of the subtype to which the aspect + -- applies with appropriate references to the parameter of the predicate + -- function or invariant procedure. The procedure passed as a generic + -- parameter does the actual replacement of node N, which is either a + -- simple direct reference to T, or a selected component that represents + -- an appropriately qualified occurrence of T. + function Rep_Item_Too_Late (T : Entity_Id; N : Node_Id; diff --git a/main/gcc/ada/sem_ch3.adb b/main/gcc/ada/sem_ch3.adb index 1f89f2e9b9e..dd71672d39b 100644 --- a/main/gcc/ada/sem_ch3.adb +++ b/main/gcc/ada/sem_ch3.adb @@ -35,7 +35,6 @@ with Exp_Ch3; use Exp_Ch3; with Exp_Ch9; use Exp_Ch9; with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; -with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; @@ -93,8 +92,8 @@ package body Sem_Ch3 is -- record type. procedure Analyze_Object_Contract (Obj_Id : Entity_Id); - -- Analyze all delayed aspects chained on the contract of object Obj_Id as - -- if they appeared at the end of the declarative region. The aspects to be + -- Analyze all delayed pragmas chained on the contract of object Obj_Id as + -- if they appeared at the end of the declarative region. The pragmas to be -- considered are: -- Async_Readers -- Async_Writers @@ -361,16 +360,13 @@ package body Sem_Ch3 is Related_Node : Node_Id; Typ : Entity_Id; Constraints : Elist_Id) return Entity_Id; - -- Given a discriminated base type Typ, a list of discriminant constraint - -- Constraints for Typ and a component of Typ, with type Compon_Type, - -- create and return the type corresponding to Compon_type where all - -- discriminant references are replaced with the corresponding constraint. - -- If no discriminant references occur in Compon_Typ then return it as is. - -- Constrained_Typ is the final constrained subtype to which the - -- constrained Compon_Type belongs. Related_Node is the node where we will - -- attach all the itypes created. - -- - -- Above description is confused, what is Compon_Type??? + -- Given a discriminated base type Typ, a list of discriminant constraints, + -- Constraints, for Typ and a component Comp of Typ, create and return the + -- type corresponding to Etype (Comp) where all discriminant references + -- are replaced with the corresponding constraint. If Etype (Comp) contains + -- no discriminant references then it is returned as-is. Constrained_Typ + -- is the final constrained subtype to which the constrained component + -- belongs. Related_Node is the node where we attach all created itypes. procedure Constrain_Access (Def_Id : in out Entity_Id; @@ -416,15 +412,14 @@ package body Sem_Ch3 is -- Def_Id is an in/out parameter). -- -- Related_Nod gives the place where this type has to be inserted - -- in the tree + -- in the tree. -- -- The last two arguments are used to create its external name if needed. function Constrain_Corresponding_Record (Prot_Subt : Entity_Id; Corr_Rec : Entity_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id) return Entity_Id; + Related_Nod : Node_Id) return Entity_Id; -- When constraining a protected type or task type with discriminants, -- constrain the corresponding record with the same discriminant values. @@ -591,6 +586,10 @@ package body Sem_Ch3 is -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id); + -- Propagate static and dynamic predicate flags from a parent to the + -- subtype in a subtype declaration with and without constraints. + function Is_Valid_Constraint_Kind (T_Kind : Type_Kind; Constraint_Kind : Node_Kind) return Boolean; @@ -699,6 +698,11 @@ package body Sem_Ch3 is -- scalar range. Subt provides the parent subtype to be used to analyze, -- resolve, and check the given range. + procedure Set_Default_SSO (T : Entity_Id); + -- T is the entity for an array or record being declared. This procedure + -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according + -- to the setting of Opt.Default_SSO. + procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id); -- Create a new signed integer entity, and apply the constraint to obtain -- the required first named subtype of this type. @@ -726,7 +730,7 @@ package body Sem_Ch3 is Enclosing_Prot_Type : Entity_Id := Empty; begin - Check_SPARK_Restriction ("access type is not allowed", N); + Check_SPARK_05_Restriction ("access type is not allowed", N); if Is_Entry (Current_Scope) and then Is_Task_Type (Etype (Scope (Current_Scope))) @@ -846,8 +850,7 @@ package body Sem_Ch3 is Set_Ekind (Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type); else - Set_Ekind - (Anon_Type, E_Anonymous_Access_Subprogram_Type); + Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type); end if; Set_Can_Use_Internal_Rep @@ -1050,7 +1053,7 @@ package body Sem_Ch3 is -- Start of processing for Access_Subprogram_Declaration begin - Check_SPARK_Restriction ("access type is not allowed", T_Def); + Check_SPARK_05_Restriction ("access type is not allowed", T_Def); -- Associate the Itype node with the inner full-type declaration or -- subprogram spec or entry body. This is required to handle nested @@ -1319,7 +1322,7 @@ package body Sem_Ch3 is Full_Desig : Entity_Id; begin - Check_SPARK_Restriction ("access type is not allowed", Def); + Check_SPARK_05_Restriction ("access type is not allowed", Def); -- Check for permissible use of incomplete type @@ -1328,9 +1331,51 @@ package body Sem_Ch3 is if 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 + -- the full view contains tasks, and there is no way to handle + -- that full view in a client. We create a master entity for the + -- scope, which will be used when a client determines that one + -- is needed. + + if From_Limited_With (Entity (S)) + and then not Is_Class_Wide_Type (Entity (S)) + then + Set_Ekind (T, E_Access_Type); + Build_Master_Entity (T); + Build_Master_Renaming (T); + end if; + else - Set_Directly_Designated_Type (T, - Process_Subtype (S, P, T, 'P')); + Set_Directly_Designated_Type (T, Process_Subtype (S, P, T, 'P')); + end if; + + -- If the access definition is of the form: ACCESS NOT NULL .. + -- the subtype indication must be of an access type. Create + -- a null-excluding subtype of it. + + if Null_Excluding_Subtype (Def) then + if not Is_Access_Type (Entity (S)) then + Error_Msg_N ("null exclusion must apply to access type", Def); + + else + declare + Loc : constant Source_Ptr := Sloc (S); + Decl : Node_Id; + Nam : constant Entity_Id := Make_Temporary (Loc, 'S'); + + begin + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Nam, + Subtype_Indication => + New_Occurrence_Of (Entity (S), Loc)); + Set_Null_Exclusion_Present (Decl); + Insert_Before (Parent (Def), Decl); + Analyze (Decl); + Set_Entity (S, Nam); + end; + end if; end if; else @@ -1351,7 +1396,7 @@ package body Sem_Ch3 is -- In Ada 2005, the type may have a limited view through some unit in -- its own context, allowing the following circularity that cannot be - -- detected earlier + -- detected earlier. elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T then @@ -1374,10 +1419,12 @@ package body Sem_Ch3 is -- Note that Has_Task is always false, since the access type itself -- is not a task type. See Einfo for more description on this point. - -- Exactly the same consideration applies to Has_Controlled_Component. + -- Exactly the same consideration applies to Has_Controlled_Component + -- and to Has_Protected. - Set_Has_Task (T, False); + Set_Has_Task (T, False); Set_Has_Controlled_Component (T, False); + Set_Has_Protected (T, False); -- Initialize field Finalization_Master explicitly to Empty, to avoid -- problems where an incomplete view of this entity has been previously @@ -1837,7 +1884,7 @@ package body Sem_Ch3 is (Subtype_Indication (Component_Definition (N)), N); if not Nkind_In (Typ, N_Identifier, N_Expanded_Name) then - Check_SPARK_Restriction ("subtype mark required", Typ); + Check_SPARK_05_Restriction ("subtype mark required", Typ); end if; -- Ada 2005 (AI-230): Access Definition case @@ -1890,8 +1937,8 @@ package body Sem_Ch3 is -- package Sem). if Present (E) then - Check_SPARK_Restriction ("default expression is not allowed", E); - Preanalyze_Spec_Expression (E, T); + Check_SPARK_05_Restriction ("default expression is not allowed", E); + Preanalyze_Default_Expression (E, T); Check_Initialization (T, E); if Ada_Version >= Ada_2005 @@ -2111,7 +2158,6 @@ package body Sem_Ch3 is Spec_Id : Entity_Id; Dummy : Entity_Id; - pragma Unreferenced (Dummy); -- A dummy variable used to capture the unused result of subprogram -- spec analysis. @@ -2210,7 +2256,7 @@ package body Sem_Ch3 is if Nkind (Decl) = N_Package_Declaration and then Nkind (Parent (L)) = N_Package_Specification then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("package specification cannot contain a package declaration", Decl); end if; @@ -2347,6 +2393,15 @@ 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. @@ -2503,7 +2558,7 @@ package body Sem_Ch3 is when N_Record_Definition => if Present (Discriminant_Specifications (N)) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("discriminant type is not allowed", Defining_Identifier (First (Discriminant_Specifications (N)))); @@ -2612,7 +2667,7 @@ package body Sem_Ch3 is -- Controlled type is not allowed in SPARK if Is_Visibly_Controlled (T) then - Check_SPARK_Restriction ("controlled type is not allowed", N); + Check_SPARK_05_Restriction ("controlled type is not allowed", N); end if; -- Some common processing for all types @@ -2729,7 +2784,7 @@ package body Sem_Ch3 is T : Entity_Id; begin - Check_SPARK_Restriction ("incomplete type is not allowed", N); + Check_SPARK_05_Restriction ("incomplete type is not allowed", N); Generate_Definition (Defining_Identifier (N)); @@ -2888,6 +2943,11 @@ package body Sem_Ch3 is if not Is_Overloaded (E) then T := Etype (E); + if Has_Dynamic_Predicate_Aspect (T) then + Error_Msg_N + ("subtype has dynamic predicate, " + & "not allowed in number declaration", N); + end if; else T := Any_Type; @@ -2990,13 +3050,13 @@ package body Sem_Ch3 is begin if Ekind (Obj_Id) = E_Constant then - -- A constant cannot be volatile. This check is only relevant when - -- SPARK_Mode is on as it is not standard Ada legality rule. Do not - -- flag internally-generated constants that map generic formals to - -- actuals in instantiations (SPARK RM 7.1.3(6)). + -- A constant cannot be effectively volatile. This check is only + -- relevant with SPARK_Mode on as it is not a standard Ada legality + -- rule. Do not flag internally-generated constants that map generic + -- formals to actuals in instantiations (SPARK RM 7.1.3(6)). if SPARK_Mode = On - and then Is_SPARK_Volatile (Obj_Id) + and then Is_Effectively_Volatile (Obj_Id) and then No (Corresponding_Generic_Association (Parent (Obj_Id))) then Error_Msg_N ("constant cannot be volatile", Obj_Id); @@ -3005,40 +3065,41 @@ package body Sem_Ch3 is else pragma Assert (Ekind (Obj_Id) = E_Variable); -- The following checks are only relevant when SPARK_Mode is on as - -- they are not standard Ada legality rules. + -- they are not standard Ada legality rules. Internally generated + -- temporaries are ignored. - if SPARK_Mode = On then - if Is_SPARK_Volatile (Obj_Id) then + if SPARK_Mode = On and then Comes_From_Source (Obj_Id) then + if Is_Effectively_Volatile (Obj_Id) then - -- The declaration of a volatile object must appear at the - -- library level (SPARK RM 7.1.3(7), C.6(6)). + -- The declaration of an effectively volatile object must + -- appear at the library level (SPARK RM 7.1.3(7), C.6(6)). if not Is_Library_Level_Entity (Obj_Id) then Error_Msg_N ("volatile variable & must be declared at library level", Obj_Id); - -- An object of a discriminated type cannot be volatile - -- (SPARK RM C.6(4)). + -- An object of a discriminated type cannot be effectively + -- volatile (SPARK RM C.6(4)). elsif Has_Discriminants (Obj_Typ) then Error_Msg_N ("discriminated object & cannot be volatile", Obj_Id); - -- An object of a tagged type cannot be volatile + -- An object of a tagged type cannot be effectively volatile -- (SPARK RM C.6(5)). elsif Is_Tagged_Type (Obj_Typ) then Error_Msg_N ("tagged object & cannot be volatile", Obj_Id); end if; - -- The object is not volatile + -- The object is not effectively volatile else - -- A non-volatile object cannot have volatile components - -- (SPARK RM 7.1.3(7)). + -- A non-effectively volatile object cannot have effectively + -- volatile components (SPARK RM 7.1.3(7)). - if not Is_SPARK_Volatile (Obj_Id) + if not Is_Effectively_Volatile (Obj_Id) and then Has_Volatile_Component (Obj_Typ) then Error_Msg_N @@ -3154,7 +3215,7 @@ package body Sem_Ch3 is while Present (X) loop C := Etype (X); - if not Is_Static_Subtype (C) then + if not Is_OK_Static_Subtype (C) then Check_Restriction (Max_Tasks, N); return Uint_0; else @@ -3389,21 +3450,21 @@ package body Sem_Ch3 is -- is considered, so that the Object_Definition node is still the same -- as in source code. - -- In SPARK, the nominal subtype shall be given by a subtype mark and - -- shall not be unconstrained. (The only exception to this is the - -- admission of declarations of constants of type String.) + -- In SPARK, the nominal subtype is always given by a subtype mark + -- and must not be unconstrained. (The only exception to this is the + -- acceptance of declarations of constants of type String.) if not Nkind_In (Object_Definition (N), N_Identifier, N_Expanded_Name) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subtype mark required", Object_Definition (N)); elsif Is_Array_Type (T) and then not Is_Constrained (T) and then T /= Standard_String then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subtype mark of constrained type expected", Object_Definition (N)); end if; @@ -3411,7 +3472,7 @@ package body Sem_Ch3 is -- There are no aliased objects in SPARK if Aliased_Present (N) then - Check_SPARK_Restriction ("aliased object is not allowed", N); + Check_SPARK_05_Restriction ("aliased object is not allowed", N); end if; -- Process initialization expression if present and not in error @@ -3464,7 +3525,21 @@ package body Sem_Ch3 is -- early usage within E is properly diagnosed. Set_Etype (Id, T); - Resolve (E, T); + + -- If the expression is an aggregate we must look ahead to detect + -- the possible presence of an address clause, and defer resolution + -- and expansion of the aggregate to the freeze point of the entity. + + if Comes_From_Source (N) + and then Expander_Active + and then Has_Following_Address_Clause (N) + and then Nkind (E) = N_Aggregate + then + Set_Etype (E, T); + + else + Resolve (E, T); + end if; -- No further action needed if E is a call to an inlined function -- which returns an unconstrained type and it has been expanded into @@ -3472,7 +3547,7 @@ package body Sem_Ch3 is -- declaration without initializing expression and it has been -- analyzed (see Expand_Inlined_Call). - if Debug_Flag_Dot_K + if Back_End_Inlining and then Expander_Active and then Nkind (E) = N_Function_Call and then Nkind (Name (E)) in N_Has_Entity @@ -3552,9 +3627,9 @@ package body Sem_Ch3 is -- Only call test if needed and then Restriction_Check_Required (SPARK_05) - and then not Is_SPARK_Initialization_Expr (Original_Node (E)) + and then not Is_SPARK_05_Initialization_Expr (Original_Node (E)) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("initialization expression is not appropriate", E); end if; end if; @@ -3610,7 +3685,7 @@ package body Sem_Ch3 is -- only for constants of type string. if Is_String_Type (T) and then not Constant_Present (N) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("declaration of object of unconstrained type not allowed", N); end if; @@ -3694,6 +3769,14 @@ package body Sem_Ch3 is elsif Is_Interface (T) then null; + -- In GNATprove mode, Expand_Subtype_From_Expr does nothing. Thus, + -- we should prevent the generation of another Itype with the + -- same name as the one already generated, or we end up with + -- two identical types in GNATprove. + + elsif GNATprove_Mode then + null; + else Expand_Subtype_From_Expr (N, T, Object_Definition (N), E); Act_T := Find_Type_Of_Object (Object_Definition (N), N); @@ -3876,10 +3959,13 @@ package body Sem_Ch3 is Set_Etype (Id, Act_T); - -- Object is marked to be treated as volatile if type is volatile and - -- we clear the Current_Value setting that may have been set above. + -- Non-constant object is marked to be treated as volatile if type is + -- volatile and we clear the Current_Value setting that may have been + -- set above. Doing so for constants isn't required and might interfere + -- with possible uses of the object as a static expression in contexts + -- incompatible with volatility (e.g. as a case-statement alternative). - if Treat_As_Volatile (Etype (Id)) then + if Ekind (Id) /= E_Constant and then Treat_As_Volatile (Etype (Id)) then Set_Treat_As_Volatile (Id); Set_Current_Value (Id, Empty); end if; @@ -4174,9 +4260,11 @@ package body Sem_Ch3 is Set_Scope (T, Current_Scope); Set_Ekind (T, E_Record_Type_With_Private); 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_Convention (T, Convention (Parent_Type)); Set_First_Rep_Item (T, First_Rep_Item (Parent_Type)); @@ -4389,7 +4477,7 @@ package body Sem_Ch3 is if Is_Boolean_Type (T) and then Nkind (Subtype_Indication (N)) = N_Subtype_Indication then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subtype of Boolean cannot have constraint", N); end if; @@ -4411,7 +4499,7 @@ package body Sem_Ch3 is if not Nkind_In (One_Cstr, N_Identifier, N_Expanded_Name) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subtype mark required", One_Cstr); -- String subtype must have a lower bound of 1 in SPARK. @@ -4425,7 +4513,7 @@ package body Sem_Ch3 is if Is_OK_Static_Expression (Low) and then Expr_Value (Low) /= 1 then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("String subtype must have lower bound of 1", N); end if; end if; @@ -4447,7 +4535,7 @@ package body Sem_Ch3 is -- in SPARK. if Is_Array_Type (T) and then not Is_Constrained (T) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subtype of unconstrained array must have constraint", N); end if; @@ -4476,6 +4564,7 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); + Inherit_Predicate_Flags (Id, T); when Ordinary_Fixed_Point_Kind => Set_Ekind (Id, E_Ordinary_Fixed_Point_Subtype); @@ -4498,6 +4587,7 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); + Inherit_Predicate_Flags (Id, T); when Modular_Integer_Kind => Set_Ekind (Id, E_Modular_Integer_Subtype); @@ -4505,6 +4595,7 @@ package body Sem_Ch3 is Set_Is_Constrained (Id, Is_Constrained (T)); Set_Is_Known_Valid (Id, Is_Known_Valid (T)); Set_RM_Size (Id, RM_Size (T)); + Inherit_Predicate_Flags (Id, T); when Class_Wide_Kind => Set_Ekind (Id, E_Class_Wide_Subtype); @@ -4853,6 +4944,14 @@ 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. @@ -5018,7 +5117,7 @@ package body Sem_Ch3 is -- Check SPARK restriction requiring a subtype mark if not Nkind_In (Index, N_Identifier, N_Expanded_Name) then - Check_SPARK_Restriction ("subtype mark required", Index); + Check_SPARK_05_Restriction ("subtype mark required", Index); end if; -- Add a subtype declaration for each index of private array type @@ -5095,7 +5194,8 @@ package body Sem_Ch3 is Set_Etype (Component_Typ, Element_Type); if not Nkind_In (Component_Typ, N_Identifier, N_Expanded_Name) then - Check_SPARK_Restriction ("subtype mark required", Component_Typ); + Check_SPARK_05_Restriction + ("subtype mark required", Component_Typ); end if; -- Ada 2005 (AI-230): Access Definition case @@ -5151,6 +5251,7 @@ package body Sem_Ch3 is Set_Etype (Implicit_Base, Implicit_Base); Set_Scope (Implicit_Base, Current_Scope); Set_Has_Delayed_Freeze (Implicit_Base); + Set_Default_SSO (Implicit_Base); -- The constrained array type is a subtype of the unconstrained one @@ -5167,6 +5268,7 @@ package body Sem_Ch3 is 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 @@ -5190,12 +5292,14 @@ package body Sem_Ch3 is 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)); Set_Has_Controlled_Component (T, Has_Controlled_Component (Element_Type) or else Is_Controlled (Element_Type)); Set_Finalize_Storage_Only (T, Finalize_Storage_Only (Element_Type)); + Set_Default_SSO (T); end if; -- Common attributes for both cases @@ -5204,7 +5308,7 @@ package body Sem_Ch3 is Set_Packed_Array_Impl_Type (T, Empty); if Aliased_Present (Component_Definition (Def)) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("aliased is not allowed", Component_Definition (Def)); Set_Has_Aliased_Components (Etype (T)); end if; @@ -5675,8 +5779,8 @@ package body Sem_Ch3 is if Nkind (Indic) /= N_Subtype_Indication then Make_Implicit_Base; - Set_Ekind (Derived_Type, Ekind (Parent_Type)); - Set_Etype (Derived_Type, Implicit_Base); + Set_Ekind (Derived_Type, Ekind (Parent_Type)); + Set_Etype (Derived_Type, Implicit_Base); Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type); else @@ -6462,43 +6566,174 @@ package body Sem_Ch3 is Is_Completion : Boolean; Derive_Subps : Boolean := True) is - Loc : constant Source_Ptr := Sloc (N); - Der_Base : Entity_Id; - Discr : Entity_Id; - Full_Decl : Node_Id := Empty; - Full_Der : Entity_Id; - Full_P : Entity_Id; - Last_Discr : Entity_Id; - Par_Scope : constant Entity_Id := Scope (Base_Type (Parent_Type)); - Swapped : Boolean := False; + Loc : constant Source_Ptr := Sloc (N); + Par_Base : constant Entity_Id := Base_Type (Parent_Type); + Par_Scope : constant Entity_Id := Scope (Par_Base); + Der_Base : Entity_Id; + Discr : Entity_Id; + Full_Der : Entity_Id; + Full_P : Entity_Id; + Last_Discr : Entity_Id; + + procedure Build_Full_Derivation; + -- Build full derivation, i.e. derive from the full view procedure Copy_And_Build; -- Copy derived type declaration, replace parent with its full view, - -- and analyze new declaration. + -- and build derivation + + --------------------------- + -- Build_Full_Derivation -- + --------------------------- + + procedure Build_Full_Derivation is + begin + -- If parent scope is not open, install the declarations + + if not In_Open_Scopes (Par_Scope) then + Install_Private_Declarations (Par_Scope); + Install_Visible_Declarations (Par_Scope); + Copy_And_Build; + Uninstall_Declarations (Par_Scope); + + -- If parent scope is open and in another unit, and parent has a + -- completion, then the derivation is taking place in the visible + -- part of a child unit. In that case retrieve the full view of + -- the parent momentarily. + + elsif not In_Same_Source_Unit (N, Parent_Type) then + Full_P := Full_View (Parent_Type); + Exchange_Declarations (Parent_Type); + Copy_And_Build; + Exchange_Declarations (Full_P); + + -- Otherwise it is a local derivation + + else + Copy_And_Build; + end if; + end Build_Full_Derivation; -------------------- -- Copy_And_Build -- -------------------- procedure Copy_And_Build is - Full_N : Node_Id; + Full_N : Node_Id; + Full_Parent : Entity_Id := Parent_Type; begin - if Ekind (Parent_Type) in Record_Kind + -- If the parent is itself derived from another private type, + -- installing the private declarations has not affected its + -- privacy status, so use its own full view explicitly. + + if Is_Private_Type (Full_Parent) + and then Present (Full_View (Full_Parent)) + then + Full_Parent := Full_View (Full_Parent); + end if; + + -- And its underlying full view if necessary + + if Is_Private_Type (Full_Parent) + and then Present (Underlying_Full_View (Full_Parent)) + then + Full_Parent := Underlying_Full_View (Full_Parent); + end if; + + -- For record, access and most enumeration types, derivation from + -- the full view requires a fully-fledged declaration. In the other + -- cases, just use an itype. + + if Ekind (Full_Parent) in Record_Kind + or else Ekind (Full_Parent) in Access_Kind or else - (Ekind (Parent_Type) in Enumeration_Kind - and then not Is_Standard_Character_Type (Parent_Type) - and then not Is_Generic_Type (Root_Type (Parent_Type))) + (Ekind (Full_Parent) in Enumeration_Kind + and then not Is_Standard_Character_Type (Full_Parent) + and then not Is_Generic_Type (Root_Type (Full_Parent))) then + -- Copy and adjust declaration to provide a completion for what + -- is originally a private declaration. Indicate that full view + -- is internally generated. + Full_N := New_Copy_Tree (N); + Full_Der := New_Copy (Derived_Type); + Set_Comes_From_Source (Full_N, False); + Set_Comes_From_Source (Full_Der, False); + Set_Parent (Full_Der, Full_N); + Set_Defining_Identifier (Full_N, Full_Der); + + -- If there are no constraints, adjust the subtype mark + + if Nkind (Subtype_Indication (Type_Definition (Full_N))) /= + N_Subtype_Indication + then + Set_Subtype_Indication + (Type_Definition (Full_N), + New_Occurrence_Of (Full_Parent, Sloc (Full_N))); + end if; + Insert_After (N, Full_N); - Build_Derived_Type ( - Full_N, Parent_Type, Full_Der, True, Derive_Subps => False); + + -- Build full view of derived type from full view of parent which + -- is now installed. Subprograms have been derived on the partial + -- view, the completion does not derive them anew. + + if Ekind (Full_Parent) in Record_Kind then + + -- If parent type is tagged, the completion inherits the proper + -- primitive operations. + + if Is_Tagged_Type (Parent_Type) then + Build_Derived_Record_Type + (Full_N, Full_Parent, Full_Der, Derive_Subps); + else + Build_Derived_Record_Type + (Full_N, Full_Parent, Full_Der, Derive_Subps => False); + end if; + + else + Build_Derived_Type + (Full_N, Full_Parent, Full_Der, True, Derive_Subps => False); + end if; + + -- The full declaration has been introduced into the tree and + -- processed in the step above. It should not be analyzed again + -- (when encountered later in the current list of declarations) + -- to prevent spurious name conflicts. The full entity remains + -- invisible. + + Set_Analyzed (Full_N); else - Build_Derived_Type ( - N, Parent_Type, Full_Der, True, Derive_Subps => False); + Full_Der := + Make_Defining_Identifier (Sloc (Derived_Type), + Chars => Chars (Derived_Type)); + Set_Is_Itype (Full_Der); + Set_Associated_Node_For_Itype (Full_Der, N); + Set_Parent (Full_Der, N); + Build_Derived_Type + (N, Full_Parent, Full_Der, True, Derive_Subps => False); end if; + + Set_Has_Private_Declaration (Full_Der); + Set_Has_Private_Declaration (Derived_Type); + + Set_Scope (Full_Der, Scope (Derived_Type)); + Set_Is_First_Subtype (Full_Der, Is_First_Subtype (Derived_Type)); + Set_Has_Size_Clause (Full_Der, False); + Set_Has_Alignment_Clause (Full_Der, False); + Set_Has_Delayed_Freeze (Full_Der); + Set_Is_Frozen (Full_Der, False); + Set_Freeze_Node (Full_Der, Empty); + Set_Depends_On_Private (Full_Der, Has_Private_Component (Full_Der)); + Set_Is_Public (Full_Der, Is_Public (Derived_Type)); + + -- The convention on the base type may be set in the private part + -- and not propagated to the subtype until later, so we obtain the + -- convention from the base type of the parent. + + Set_Convention (Full_Der, Convention (Base_Type (Full_Parent))); end Copy_And_Build; -- Start of processing for Build_Derived_Private_Type @@ -6577,6 +6812,7 @@ package body Sem_Ch3 is Set_Ekind (Full_Der, E_Record_Type); Set_Is_Underlying_Record_View (Full_Der); + Set_Default_SSO (Full_Der); Analyze (Decl); @@ -6609,18 +6845,10 @@ package body Sem_Ch3 is elsif Has_Discriminants (Parent_Type) then if Present (Full_View (Parent_Type)) then if not Is_Completion then + -- If this is not a completion, construct the implicit full + -- view by deriving from the full view of the parent type. - -- Copy declaration for subsequent analysis, to provide a - -- completion for what is a private declaration. Indicate that - -- the full type is internally generated. - - Full_Decl := New_Copy_Tree (N); - Full_Der := New_Copy (Derived_Type); - Set_Comes_From_Source (Full_Decl, False); - Set_Comes_From_Source (Full_Der, False); - Set_Parent (Full_Der, Full_Decl); - - Insert_After (N, Full_Decl); + Build_Full_Derivation; else -- If this is a completion, the full view being built is itself @@ -6657,58 +6885,7 @@ package body Sem_Ch3 is (N, Parent_Type, Derived_Type, Derive_Subps); if Present (Full_View (Parent_Type)) and then not Is_Completion then - if not In_Open_Scopes (Par_Scope) - or else not In_Same_Source_Unit (N, Parent_Type) - then - -- Swap partial and full views temporarily - - Install_Private_Declarations (Par_Scope); - Install_Visible_Declarations (Par_Scope); - Swapped := True; - end if; - - -- Build full view of derived type from full view of parent which - -- is now installed. Subprograms have been derived on the partial - -- view, the completion does not derive them anew. - - if not Is_Tagged_Type (Parent_Type) then - - -- If the parent is itself derived from another private type, - -- installing the private declarations has not affected its - -- privacy status, so use its own full view explicitly. - - if Is_Private_Type (Parent_Type) then - Build_Derived_Record_Type - (Full_Decl, Full_View (Parent_Type), Full_Der, False); - else - Build_Derived_Record_Type - (Full_Decl, Parent_Type, Full_Der, False); - end if; - - else - -- If full view of parent is tagged, the completion inherits - -- the proper primitive operations. - - Set_Defining_Identifier (Full_Decl, Full_Der); - Build_Derived_Record_Type - (Full_Decl, Parent_Type, Full_Der, Derive_Subps); - end if; - - -- The full declaration has been introduced into the tree and - -- processed in the step above. It should not be analyzed again - -- (when encountered later in the current list of declarations) - -- to prevent spurious name conflicts. The full entity remains - -- invisible. - - Set_Analyzed (Full_Decl); - - if Swapped then - Uninstall_Declarations (Par_Scope); - - if In_Open_Scopes (Par_Scope) then - Install_Visible_Declarations (Par_Scope); - end if; - end if; + -- Install full view in derived type (base type and subtype) Der_Base := Base_Type (Derived_Type); Set_Full_View (Derived_Type, Full_Der); @@ -6736,18 +6913,10 @@ package body Sem_Ch3 is Set_First_Entity (Derived_Type, First_Entity (Der_Base)); Set_Last_Entity (Derived_Type, Last_Entity (Der_Base)); Set_Stored_Constraint (Full_Der, Stored_Constraint (Derived_Type)); - - else - -- If this is a completion, the derived type stays private and - -- there is no need to create a further full view, except in the - -- unusual case when the derivation is nested within a child unit, - -- see below. - - null; end if; elsif Present (Full_View (Parent_Type)) - and then Has_Discriminants (Full_View (Parent_Type)) + and then Has_Discriminants (Full_View (Parent_Type)) then if Has_Unknown_Discriminants (Parent_Type) and then Nkind (Subtype_Indication (Type_Definition (N))) = @@ -6759,43 +6928,17 @@ package body Sem_Ch3 is return; end if; - -- If full view of parent is a record type, build full view as a - -- derivation from the parent's full view. Partial view remains - -- private. For code generation and linking, the full view must have - -- the same public status as the partial one. This full view is only - -- needed if the parent type is in an enclosing scope, so that the - -- full view may actually become visible, e.g. in a child unit. This - -- is both more efficient, and avoids order of freezing problems with - -- the added entities. + -- If this is not a completion, construct the implicit full view by + -- deriving from the full view of the parent type. But if this is a + -- completion, the derived private type being built is a full view + -- and the full derivation can only be its underlying full view. - if not Is_Private_Type (Full_View (Parent_Type)) - and then (In_Open_Scopes (Scope (Parent_Type))) - then - Full_Der := - Make_Defining_Identifier (Sloc (Derived_Type), - Chars => Chars (Derived_Type)); + Build_Full_Derivation; - Set_Is_Itype (Full_Der); - Set_Has_Private_Declaration (Full_Der); - Set_Has_Private_Declaration (Derived_Type); - Set_Associated_Node_For_Itype (Full_Der, N); - Set_Parent (Full_Der, Parent (Derived_Type)); + if not Is_Completion then Set_Full_View (Derived_Type, Full_Der); - Set_Is_Public (Full_Der, Is_Public (Derived_Type)); - Full_P := Full_View (Parent_Type); - Exchange_Declarations (Parent_Type); - Copy_And_Build; - Exchange_Declarations (Full_P); - else - Build_Derived_Record_Type - (N, Full_View (Parent_Type), Derived_Type, - Derive_Subps => False); - - -- Except in the context of the full view of the parent, there - -- are no non-extension aggregates for the derived type. - - Set_Has_Private_Ancestor (Derived_Type); + Set_Underlying_Full_View (Derived_Type, Full_Der); end if; -- In any case, the primitive operations are inherited from the @@ -6807,6 +6950,10 @@ package body Sem_Ch3 is Derive_Subprograms (Parent_Type, Derived_Type); end if; + Set_Stored_Constraint (Derived_Type, No_Elist); + Set_Is_Constrained + (Derived_Type, Is_Constrained (Full_View (Parent_Type))); + else -- Untagged type, No discriminants on either view @@ -6838,9 +6985,8 @@ package body Sem_Ch3 is (Base_Type (Derived_Type), Finalize_Storage_Only (Parent_Type)); end if; - -- Construct the implicit full view by deriving from full view of the - -- parent type. In order to get proper visibility, we install the - -- parent scope and its declarations. + -- If this is not a completion, construct the implicit full view by + -- deriving from the full view of the parent type. -- ??? If the parent is untagged private and its completion is -- tagged, this mechanism will not work because we cannot derive from @@ -6850,51 +6996,8 @@ package body Sem_Ch3 is and then not Is_Tagged_Type (Full_View (Parent_Type)) and then not Is_Completion then - Full_Der := - Make_Defining_Identifier - (Sloc (Derived_Type), Chars (Derived_Type)); - Set_Is_Itype (Full_Der); - Set_Has_Private_Declaration (Full_Der); - Set_Has_Private_Declaration (Derived_Type); - Set_Associated_Node_For_Itype (Full_Der, N); - Set_Parent (Full_Der, Parent (Derived_Type)); + Build_Full_Derivation; Set_Full_View (Derived_Type, Full_Der); - - if not In_Open_Scopes (Par_Scope) then - Install_Private_Declarations (Par_Scope); - Install_Visible_Declarations (Par_Scope); - Copy_And_Build; - Uninstall_Declarations (Par_Scope); - - -- If parent scope is open and in another unit, and parent has a - -- completion, then the derivation is taking place in the visible - -- part of a child unit. In that case retrieve the full view of - -- the parent momentarily. - - elsif not In_Same_Source_Unit (N, Parent_Type) then - Full_P := Full_View (Parent_Type); - Exchange_Declarations (Parent_Type); - Copy_And_Build; - Exchange_Declarations (Full_P); - - -- Otherwise it is a local derivation - - else - Copy_And_Build; - end if; - - Set_Scope (Full_Der, Current_Scope); - Set_Is_First_Subtype (Full_Der, - Is_First_Subtype (Derived_Type)); - Set_Has_Size_Clause (Full_Der, False); - Set_Has_Alignment_Clause (Full_Der, False); - Set_Next_Entity (Full_Der, Empty); - Set_Has_Delayed_Freeze (Full_Der); - Set_Is_Frozen (Full_Der, False); - Set_Freeze_Node (Full_Der, Empty); - Set_Depends_On_Private (Full_Der, - Has_Private_Component (Full_Der)); - Set_Public_Status (Full_Der); end if; end if; @@ -6905,10 +7008,12 @@ package body Sem_Ch3 is Set_Private_Dependents (Derived_Type, New_Elmt_List); end if; - if Is_Private_Type (Parent_Type) - and then Base_Type (Parent_Type) = Parent_Type - and then In_Open_Scopes (Scope (Parent_Type)) - then + -- If the parent base type is in scope, add the derived type to its + -- list of private dependents, because its full view may become + -- visible subsequently (in a nested private part, a body, or in a + -- further child unit). + + if Is_Private_Type (Par_Base) and then In_Open_Scopes (Par_Scope) then Append_Elmt (Derived_Type, Private_Dependents (Parent_Type)); -- Check for unusual case where a type completed by a private @@ -6929,29 +7034,21 @@ package body Sem_Ch3 is then -- In this case, the full view of the parent type will become -- visible in the body of the enclosing child, and only then will - -- the current type be possibly non-private. We build an - -- underlying full view that will be installed when the enclosing - -- child body is compiled. + -- the current type be possibly non-private. Build an underlying + -- full view that will be installed when the enclosing child body + -- is compiled. - Full_Der := - Make_Defining_Identifier - (Sloc (Derived_Type), Chars (Derived_Type)); - Set_Is_Itype (Full_Der); - Build_Itype_Reference (Full_Der, N); + if Present (Underlying_Full_View (Derived_Type)) then + Full_Der := Underlying_Full_View (Derived_Type); + else + Build_Full_Derivation; + Set_Underlying_Full_View (Derived_Type, Full_Der); + end if; -- The full view will be used to swap entities on entry/exit to -- the body, and must appear in the entity list for the package. Append_Entity (Full_Der, Scope (Derived_Type)); - Set_Has_Private_Declaration (Full_Der); - Set_Has_Private_Declaration (Derived_Type); - Set_Associated_Node_For_Itype (Full_Der, N); - Set_Parent (Full_Der, Parent (Derived_Type)); - Full_P := Full_View (Parent_Type); - Exchange_Declarations (Parent_Type); - Copy_And_Build; - Exchange_Declarations (Full_P); - Set_Underlying_Full_View (Derived_Type, Full_Der); end if; end if; end Build_Derived_Private_Type; @@ -7017,10 +7114,10 @@ package body Sem_Ch3 is -- Furthermore if a KNOWN_DISCRIMINANT_PART is provided, then [3.7(13-18)]: - -- o The parent subtype shall be constrained; + -- o The parent subtype must be constrained; -- o If the parent type is not a tagged type, then each discriminant of - -- the derived type shall be used in the constraint defining a parent + -- the derived type must be used in the constraint defining a parent -- subtype. [Implementation note: This ensures that the new discriminant -- can share storage with an existing discriminant.] @@ -7277,8 +7374,8 @@ package body Sem_Ch3 is -- [7.3(10-13)]: -- o If a private extension inherits known discriminants from the ancestor - -- subtype, then the full view shall also inherit its discriminants from - -- the ancestor subtype and the parent subtype of the full view shall be + -- subtype, then the full view must also inherit its discriminants from + -- the ancestor subtype and the parent subtype of the full view must be -- constrained if and only if the ancestor subtype is constrained. -- o If a partial view has unknown discriminants, then the full view may @@ -7286,10 +7383,10 @@ package body Sem_Ch3 is -- discriminants. -- o If a partial view has neither known nor unknown discriminants, then - -- the full view shall define a definite subtype. + -- the full view must define a definite subtype. -- o If the ancestor subtype of a private extension has constrained - -- discriminants, then the parent subtype of the full view shall impose a + -- discriminants, then the parent subtype of the full view must impose a -- statically matching constraint on those discriminants. -- This means that only the following forms of private extensions are @@ -7491,6 +7588,7 @@ package body Sem_Ch3 is if Private_Extension then Type_Def := N; Set_Ekind (Derived_Type, E_Record_Type_With_Private); + Set_Default_SSO (Derived_Type); else Type_Def := Type_Definition (N); @@ -7504,6 +7602,7 @@ package body Sem_Ch3 is if Present (Record_Extension_Part (Type_Def)) then Set_Ekind (Derived_Type, E_Record_Type); + Set_Default_SSO (Derived_Type); -- Create internal access types for components with anonymous -- access types. @@ -7814,7 +7913,6 @@ package body Sem_Ch3 is else declare GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type); - begin if Present (GB) and then GB /= Enclosing_Generic_Body (Parent_Base) @@ -8357,11 +8455,12 @@ package body Sem_Ch3 is -- STEP 5c: Process the record extension for non private tagged types elsif not Private_Extension then - - -- Add the _parent field in the derived type - Expand_Record_Extension (Derived_Type, Type_Def); + -- Note : previously in ASIS mode we set the Parent_Subtype of the + -- derived type to propagate some semantic information. This led + -- to other ASIS failures and has been removed. + -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces if we are in expansion mode @@ -8431,6 +8530,23 @@ package body Sem_Ch3 is end if; Check_Function_Writable_Actuals (N); + + -- 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. + + if Has_Inherited_Default_Init_Cond (Parent_Type) + or else Present (Get_Pragma + (Parent_Type, Pragma_Default_Initial_Condition)) + then + Set_Has_Inherited_Default_Init_Cond (Derived_Type); + + elsif Has_Default_Init_Cond (Parent_Type) then + Set_Has_Default_Init_Cond (Derived_Type); + end if; end Build_Derived_Record_Type; ------------------------ @@ -8451,21 +8567,37 @@ package body Sem_Ch3 is Set_Scope (Derived_Type, Current_Scope); - Set_Ekind (Derived_Type, Ekind (Parent_Base)); - Set_Etype (Derived_Type, Parent_Base); - Set_Has_Task (Derived_Type, Has_Task (Parent_Base)); + 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_Size_Info (Derived_Type, Parent_Type); Set_RM_Size (Derived_Type, RM_Size (Parent_Type)); Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + -- If the parent has primitive routines, set the derived type link + + if Has_Primitive_Operations (Parent_Type) then + Set_Derived_Type_Link (Parent_Base, Derived_Type); + end if; + -- If the parent type is a private subtype, the convention on the base -- type may be set in the private part, and not propagated to the -- subtype until later, so we obtain the convention from the base type. Set_Convention (Derived_Type, Convention (Parent_Base)); + -- Set SSO default for record or array type + + if (Is_Array_Type (Derived_Type) + or else Is_Record_Type (Derived_Type)) + and then Is_Base_Type (Derived_Type) + then + 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. @@ -8479,56 +8611,55 @@ package body Sem_Ch3 is -- The derived type inherits the representation clauses of the parent. -- However, for a private type that is completed by a derivation, there -- may be operation attributes that have been specified already (stream - -- attributes and External_Tag) and those must be provided. Finally, - -- if the partial view is a private extension, the representation items - -- of the parent have been inherited already, and should not be chained + -- attributes and External_Tag) and those must be provided. Finally, if + -- the partial view is a private extension, the representation items of + -- the parent have been inherited already, and should not be chained -- twice to the derived type. - if Is_Tagged_Type (Parent_Type) - and then Present (First_Rep_Item (Derived_Type)) - then - -- The existing items are either operational items or items inherited - -- from a private extension declaration. + -- Historic note: The guard below used to check whether the parent type + -- is tagged. This is no longer needed because an untagged derived type + -- may carry rep items of its own as a result of certain SPARK pragmas. + -- With the old guard in place, the rep items of the derived type were + -- clobbered. + if Present (First_Rep_Item (Derived_Type)) then declare - Rep : Node_Id; - -- Used to iterate over representation items of the derived type - - Last_Rep : Node_Id; - -- Last representation item of the (non-empty) representation - -- item list of the derived type. - - Found : Boolean := False; + Par_Item : constant Node_Id := First_Rep_Item (Parent_Type); + Inherited : Boolean := False; + Item : Node_Id; + Last_Item : Node_Id; begin - Rep := First_Rep_Item (Derived_Type); - Last_Rep := Rep; - while Present (Rep) loop - if Rep = First_Rep_Item (Parent_Type) then - Found := True; + -- Inspect the rep item chain of the derived type and perform the + -- following two functions: + -- 1) Determine whether the derived type already inherited the + -- rep items of the parent type. + -- 2) Find the last rep item of the derived type + + Item := First_Rep_Item (Derived_Type); + Last_Item := Item; + while Present (Item) loop + if Item = Par_Item then + Inherited := True; exit; - - else - Rep := Next_Rep_Item (Rep); - - if Present (Rep) then - Last_Rep := Rep; - end if; end if; + + Last_Item := Item; + Item := Next_Rep_Item (Item); end loop; - -- Here if we either encountered the parent type's first rep - -- item on the derived type's rep item list (in which case - -- Found is True, and we have nothing else to do), or if we - -- reached the last rep item of the derived type, which is - -- Last_Rep, in which case we further chain the parent type's - -- rep items to those of the derived type. + -- Nothing to do if the derived type already inherited the rep + -- items from the parent type, otherwise append the parent rep + -- item chain to that of the derived type. - if not Found then - Set_Next_Rep_Item (Last_Rep, First_Rep_Item (Parent_Type)); + if not Inherited then + Set_Next_Rep_Item (Last_Item, Par_Item); end if; end; + -- Otherwise the derived type lacks rep items and directly inherits the + -- rep items of the parent type. + else Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type)); end if; @@ -10226,6 +10357,8 @@ package body Sem_Ch3 is procedure Check_Initialization (T : Entity_Id; Exp : Node_Id) is begin + -- Special processing for limited types + if Is_Limited_Type (T) and then not In_Instance and then not In_Inlined_Body @@ -10279,6 +10412,16 @@ package body Sem_Ch3 is end if; end if; end if; + + -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag gets + -- set unless we can be sure that no range check is required. + + if (GNATprove_Mode or not Expander_Active) + and then Is_Scalar_Type (T) + and then not Is_In_Range (Exp, T, Assume_Valid => True) + then + Set_Do_Range_Check (Exp); + end if; end Check_Initialization; ---------------------- @@ -10871,8 +11014,7 @@ package body Sem_Ch3 is then Set_Corresponding_Record_Type (Full, Constrain_Corresponding_Record - (Full, Corresponding_Record_Type (Full_Base), - Related_Nod, Full_Base)); + (Full, Corresponding_Record_Type (Full_Base), Related_Nod)); else Set_Corresponding_Record_Type (Full, @@ -11200,24 +11342,6 @@ package body Sem_Ch3 is Desig_Subtype : Entity_Id := Create_Itype (E_Void, Related_Nod); Constraint_OK : Boolean := True; - function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; - -- Simple predicate to test for defaulted discriminants - -- Shouldn't this be in sem_util??? - - --------------------------------- - -- Has_Defaulted_Discriminants -- - --------------------------------- - - function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is - begin - return Has_Discriminants (Typ) - and then Present (First_Discriminant (Typ)) - and then Present - (Discriminant_Default_Value (First_Discriminant (Typ))); - end Has_Defaulted_Discriminants; - - -- Start of processing for Constrain_Access - begin if Is_Array_Type (Desig_Type) then Constrain_Array (Desig_Subtype, S, Related_Nod, Def_Id, 'P'); @@ -11312,8 +11436,7 @@ package body Sem_Ch3 is or else Is_Protected_Type (Desig_Type)) and then not Is_Constrained (Desig_Type) then - Constrain_Concurrent - (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); + Constrain_Concurrent (Desig_Subtype, S, Related_Nod, Desig_Type, ' '); else Error_Msg_N ("invalid constraint on access type", S); @@ -11508,7 +11631,6 @@ package body Sem_Ch3 is is Loc : constant Source_Ptr := Sloc (Constrained_Typ); Compon_Type : constant Entity_Id := Etype (Comp); - Array_Comp : Node_Id; function Build_Constrained_Array_Type (Old_Type : Entity_Id) return Entity_Id; @@ -11906,22 +12028,7 @@ package body Sem_Ch3 is return Compon_Type; elsif Is_Array_Type (Compon_Type) then - Array_Comp := Build_Constrained_Array_Type (Compon_Type); - - -- If the component of the parent is packed, and the record type is - -- already frozen, as is the case for an itype, the component type - -- itself will not be frozen, and the packed array type for it must - -- be constructed explicitly. Since the creation of packed types is - -- an expansion activity, we only do this if expansion is active. - - if Expander_Active - and then Is_Packed (Compon_Type) - and then Is_Frozen (Current_Scope) - then - Create_Packed_Array_Impl_Type (Array_Comp); - end if; - - return Array_Comp; + return Build_Constrained_Array_Type (Compon_Type); elsif Has_Discriminants (Compon_Type) then return Build_Constrained_Discriminated_Type (Compon_Type); @@ -11972,8 +12079,7 @@ package body Sem_Ch3 is Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); Set_Corresponding_Record_Type (Def_Id, - Constrain_Corresponding_Record - (Def_Id, T_Val, Related_Nod, Related_Id)); + Constrain_Corresponding_Record (Def_Id, T_Val, Related_Nod)); else -- If there is no associated record, expansion is disabled and this @@ -11995,11 +12101,10 @@ package body Sem_Ch3 is function Constrain_Corresponding_Record (Prot_Subt : Entity_Id; Corr_Rec : Entity_Id; - Related_Nod : Node_Id; - Related_Id : Entity_Id) return Entity_Id + Related_Nod : Node_Id) return Entity_Id is T_Sub : constant Entity_Id := - Create_Itype (E_Record_Subtype, Related_Nod, Related_Id, 'V'); + Create_Itype (E_Record_Subtype, Related_Nod, Corr_Rec, 'C'); begin Set_Etype (T_Sub, Corr_Rec); @@ -12008,16 +12113,6 @@ package body Sem_Ch3 is Set_First_Entity (T_Sub, First_Entity (Corr_Rec)); Set_Last_Entity (T_Sub, Last_Entity (Corr_Rec)); - -- As elsewhere, we do not want to create a freeze node for this itype - -- if it is created for a constrained component of an enclosing record - -- because references to outer discriminants will appear out of scope. - - if Ekind (Scope (Prot_Subt)) /= E_Record_Type then - Conditional_Delay (T_Sub, Corr_Rec); - else - Set_Is_Frozen (T_Sub); - end if; - if Has_Discriminants (Prot_Subt) then -- False only if errors. Set_Discriminant_Constraint (T_Sub, Discriminant_Constraint (Prot_Subt)); @@ -12028,6 +12123,19 @@ package body Sem_Ch3 is Set_Depends_On_Private (T_Sub, Has_Private_Component (T_Sub)); + if Ekind (Scope (Prot_Subt)) /= E_Record_Type then + Conditional_Delay (T_Sub, Corr_Rec); + + else + -- This is a component subtype: it will be frozen in the context of + -- the enclosing record's init_proc, so that discriminant references + -- are resolved to discriminals. (Note: we used to skip freezing + -- altogether in that case, which caused errors downstream for + -- components of a bit packed array type). + + Set_Has_Delayed_Freeze (T_Sub); + end if; + return T_Sub; end Constrain_Corresponding_Record; @@ -12054,7 +12162,7 @@ package body Sem_Ch3 is else pragma Assert (Nkind (C) = N_Digits_Constraint); - Check_SPARK_Restriction ("digits constraint is not allowed", S); + Check_SPARK_05_Restriction ("digits constraint is not allowed", S); Digits_Expr := Digits_Expression (C); Analyze_And_Resolve (Digits_Expr, Any_Integer); @@ -12282,7 +12390,7 @@ package body Sem_Ch3 is if Nkind (C) = N_Digits_Constraint then - Check_SPARK_Restriction ("digits constraint is not allowed", S); + Check_SPARK_05_Restriction ("digits constraint is not allowed", S); Check_Restriction (No_Obsolescent_Features, C); if Warn_On_Obsolescent_Feature then @@ -12360,7 +12468,7 @@ package body Sem_Ch3 is Set_Etype (S, T); R := S; - Process_Range_Expr_In_Decl (R, T, Empty_List); + Process_Range_Expr_In_Decl (R, T); if not Error_Posted (S) and then @@ -12381,6 +12489,10 @@ package body Sem_Ch3 is -- The parser has verified that this is a discrete indication Resolve_Discrete_Subtype_Indication (S, T); + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in index constraint", + S, Entity (Subtype_Mark (S))); + R := Range_Expression (Constraint (S)); -- Capture values of bounds and generate temporaries for them if @@ -12509,7 +12621,7 @@ package body Sem_Ch3 is if Nkind (C) = N_Delta_Constraint then - Check_SPARK_Restriction ("delta constraint is not allowed", S); + Check_SPARK_05_Restriction ("delta constraint is not allowed", S); Check_Restriction (No_Obsolescent_Features, C); if Warn_On_Obsolescent_Feature then @@ -12755,6 +12867,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)); Set_Is_Packed (T1, Is_Packed (T2)); Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2)); @@ -13110,8 +13223,8 @@ package body Sem_Ch3 is Old_C := First_Component (Typ); while Present (Old_C) loop if Original_Record_Component (Old_C) = Old_C - and then Chars (Old_C) /= Name_uTag - and then Chars (Old_C) /= Name_uParent + and then Chars (Old_C) /= Name_uTag + and then Chars (Old_C) /= Name_uParent then Append_Elmt (Old_C, Comp_List); end if; @@ -13161,7 +13274,7 @@ package body Sem_Ch3 is Bound_Val : Ureal; begin - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("decimal fixed point type is not allowed", Def); Check_Restriction (No_Fixed_Point, Def); @@ -14716,7 +14829,7 @@ package body Sem_Ch3 is -- parent is also an interface. if Interface_Present (Def) then - Check_SPARK_Restriction ("interface is not allowed", Def); + Check_SPARK_05_Restriction ("interface is not allowed", Def); if not Is_Interface (Parent_Type) then Diagnose_Interface (Indic, Parent_Type); @@ -14958,7 +15071,7 @@ package body Sem_Ch3 is end if; -- Only composite types other than array types are allowed to have - -- discriminants. In SPARK, no types are allowed to have discriminants. + -- discriminants. if Present (Discriminant_Specifications (N)) then if (Is_Elementary_Type (Parent_Type) @@ -14969,8 +15082,11 @@ package body Sem_Ch3 is ("elementary or array type cannot have discriminants", Defining_Identifier (First (Discriminant_Specifications (N)))); Set_Has_Discriminants (T, False); + + -- The type is allowed to have discriminants + else - Check_SPARK_Restriction ("discriminant type is not allowed", N); + Check_SPARK_05_Restriction ("discriminant type is not allowed", N); end if; end if; @@ -15161,7 +15277,7 @@ package body Sem_Ch3 is -- extensions of tagged record types. if No (Extension) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("derived type is not allowed", Original_Node (N)); end if; end Derived_Type_Declaration; @@ -15343,10 +15459,10 @@ package body Sem_Ch3 is Discriminant := First_Stored_Discriminant (Explicitly_Discriminated_Type); while Present (Discriminant) loop - Append_Elmt ( - Get_Discriminant_Value ( - Discriminant, Explicitly_Discriminated_Type, Constraint), - Expansion); + Append_Elmt + (Get_Discriminant_Value + (Discriminant, Explicitly_Discriminated_Type, Constraint), + To => Expansion); Next_Stored_Discriminant (Discriminant); end loop; @@ -15963,15 +16079,6 @@ package body Sem_Ch3 is return False; end if; - -- Avoid types not matching pragma Float_Representation, if present - - if (Opt.Float_Format = 'I' and then Float_Rep (E) /= IEEE_Binary) - or else - (Opt.Float_Format = 'V' and then Float_Rep (E) /= VAX_Native) - then - return False; - end if; - -- Check for matching range, if specified if Present (Spec) then @@ -16761,6 +16868,19 @@ package body Sem_Ch3 is return Assoc_List; end Inherit_Components; + ----------------------------- + -- Inherit_Predicate_Flags -- + ----------------------------- + + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is + begin + Set_Has_Predicates (Subt, Has_Predicates (Par)); + Set_Has_Static_Predicate_Aspect + (Subt, Has_Static_Predicate_Aspect (Par)); + Set_Has_Dynamic_Predicate_Aspect + (Subt, Has_Dynamic_Predicate_Aspect (Par)); + end Inherit_Predicate_Flags; + ----------------------- -- Is_Null_Extension -- ----------------------- @@ -16908,16 +17028,10 @@ package body Sem_Ch3 is Type_Scope := Scope (Base_Type (Scope (C))); end if; - -- For an untagged type derived from a private type, the only visible - -- components are new discriminants. In an instance all components are - -- visible (see Analyze_Selected_Component). + -- This test only concerns tagged types if not Is_Tagged_Type (Original_Scope) then - return not Has_Private_Ancestor (Original_Scope) - or else In_Open_Scopes (Scope (Original_Scope)) - or else In_Instance - or else (Ekind (Original_Comp) = E_Discriminant - and then Original_Scope = Type_Scope); + return True; -- If it is _Parent or _Tag, there is no visibility issue @@ -17080,6 +17194,7 @@ package body Sem_Ch3 is Set_Is_Abstract_Type (CW_Type, False); Set_Is_Constrained (CW_Type, False); Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T)); + Set_Default_SSO (CW_Type); if Ekind (T) = E_Class_Wide_Subtype then Set_Etype (CW_Type, Etype (Base_Type (T))); @@ -17107,11 +17222,11 @@ package body Sem_Ch3 is ---------------- procedure Make_Index - (I : Node_Id; + (N : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; - Suffix_Index : Nat := 1; - In_Iter_Schm : Boolean := False) + Suffix_Index : Nat := 1; + In_Iter_Schm : Boolean := False) is R : Node_Id; T : Entity_Id; @@ -17132,13 +17247,13 @@ package body Sem_Ch3 is -- Character literals also have a universal type in the absence of -- of additional context, and are resolved to Standard_Character. - if Nkind (I) = N_Range then + if Nkind (N) = N_Range then -- The index is given by a range constraint. The bounds are known -- to be of a consistent type. - if not Is_Overloaded (I) then - T := Etype (I); + if not Is_Overloaded (N) then + T := Etype (N); -- For universal bounds, choose the specific predefined type @@ -17146,7 +17261,7 @@ package body Sem_Ch3 is T := Standard_Integer; elsif T = Any_Character then - Ambiguous_Character (Low_Bound (I)); + Ambiguous_Character (Low_Bound (N)); T := Standard_Character; end if; @@ -17155,7 +17270,7 @@ package body Sem_Ch3 is -- are available, but if a universal interpretation exists it is -- also the selected one. - elsif Universal_Interpretation (I) = Universal_Integer then + elsif Universal_Interpretation (N) = Universal_Integer then T := Standard_Integer; else @@ -17166,7 +17281,7 @@ package body Sem_Ch3 is It : Interp; begin - Get_First_Interp (I, Ind, It); + Get_First_Interp (N, Ind, It); while Present (It.Typ) loop if Is_Discrete_Type (It.Typ) then @@ -17174,7 +17289,7 @@ package body Sem_Ch3 is and then not Covers (It.Typ, T) and then not Covers (T, It.Typ) then - Error_Msg_N ("ambiguous bounds in discrete range", I); + Error_Msg_N ("ambiguous bounds in discrete range", N); exit; else T := It.Typ; @@ -17186,8 +17301,8 @@ package body Sem_Ch3 is end loop; if T = Any_Type then - Error_Msg_N ("discrete type required for range", I); - Set_Etype (I, Any_Type); + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); return; elsif T = Universal_Integer then @@ -17197,70 +17312,76 @@ package body Sem_Ch3 is end if; if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", I); - Set_Etype (I, Any_Type); + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); return; end if; - if Nkind (Low_Bound (I)) = N_Attribute_Reference - and then Attribute_Name (Low_Bound (I)) = Name_First - and then Is_Entity_Name (Prefix (Low_Bound (I))) - and then Is_Type (Entity (Prefix (Low_Bound (I)))) - and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I)))) + if Nkind (Low_Bound (N)) = N_Attribute_Reference + and then Attribute_Name (Low_Bound (N)) = Name_First + and then Is_Entity_Name (Prefix (Low_Bound (N))) + and then Is_Type (Entity (Prefix (Low_Bound (N)))) + and then Is_Discrete_Type (Entity (Prefix (Low_Bound (N)))) then -- The type of the index will be the type of the prefix, as long -- as the upper bound is 'Last of the same type. - Def_Id := Entity (Prefix (Low_Bound (I))); + Def_Id := Entity (Prefix (Low_Bound (N))); - if Nkind (High_Bound (I)) /= N_Attribute_Reference - or else Attribute_Name (High_Bound (I)) /= Name_Last - or else not Is_Entity_Name (Prefix (High_Bound (I))) - or else Entity (Prefix (High_Bound (I))) /= Def_Id + if Nkind (High_Bound (N)) /= N_Attribute_Reference + or else Attribute_Name (High_Bound (N)) /= Name_Last + or else not Is_Entity_Name (Prefix (High_Bound (N))) + or else Entity (Prefix (High_Bound (N))) /= Def_Id then Def_Id := Empty; end if; end if; - R := I; + R := N; Process_Range_Expr_In_Decl (R, T, In_Iter_Schm => In_Iter_Schm); - elsif Nkind (I) = N_Subtype_Indication then + elsif Nkind (N) = N_Subtype_Indication then -- The index is given by a subtype with a range constraint - T := Base_Type (Entity (Subtype_Mark (I))); + T := Base_Type (Entity (Subtype_Mark (N))); if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", I); - Set_Etype (I, Any_Type); + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); return; end if; - R := Range_Expression (Constraint (I)); + R := Range_Expression (Constraint (N)); Resolve (R, T); Process_Range_Expr_In_Decl - (R, Entity (Subtype_Mark (I)), In_Iter_Schm => In_Iter_Schm); + (R, Entity (Subtype_Mark (N)), In_Iter_Schm => In_Iter_Schm); + + elsif Nkind (N) = N_Attribute_Reference then - elsif Nkind (I) = N_Attribute_Reference then + -- Catch beginner's error (use of attribute other than 'Range) - -- The parser guarantees that the attribute is a RANGE attribute + if Attribute_Name (N) /= Name_Range then + Error_Msg_N ("expect attribute ''Range", N); + Set_Etype (N, Any_Type); + return; + end if; -- If the node denotes the range of a type mark, that is also the - -- resulting type, and we do no need to create an Itype for it. + -- resulting type, and we do not need to create an Itype for it. - if Is_Entity_Name (Prefix (I)) - and then Comes_From_Source (I) - and then Is_Type (Entity (Prefix (I))) - and then Is_Discrete_Type (Entity (Prefix (I))) + if Is_Entity_Name (Prefix (N)) + and then Comes_From_Source (N) + and then Is_Type (Entity (Prefix (N))) + and then Is_Discrete_Type (Entity (Prefix (N))) then - Def_Id := Entity (Prefix (I)); + Def_Id := Entity (Prefix (N)); end if; - Analyze_And_Resolve (I); - T := Etype (I); - R := I; + Analyze_And_Resolve (N); + T := Etype (N); + R := N; -- If none of the above, must be a subtype. We convert this to a -- range attribute reference because in the case of declared first @@ -17274,9 +17395,9 @@ package body Sem_Ch3 is -- original index for instantiation purposes. else - if not Is_Entity_Name (I) or else not Is_Type (Entity (I)) then - Error_Msg_N ("invalid subtype mark in discrete range ", I); - Set_Etype (I, Any_Integer); + if not Is_Entity_Name (N) or else not Is_Type (Entity (N)) then + Error_Msg_N ("invalid subtype mark in discrete range ", N); + Set_Etype (N, Any_Integer); return; else @@ -17284,31 +17405,31 @@ package body Sem_Ch3 is -- now that we can get the full view, previous analysis does -- not look specifically for a type mark. - Set_Entity (I, Get_Full_View (Entity (I))); - Set_Etype (I, Entity (I)); - Def_Id := Entity (I); + Set_Entity (N, Get_Full_View (Entity (N))); + Set_Etype (N, Entity (N)); + Def_Id := Entity (N); if not Is_Discrete_Type (Def_Id) then - Error_Msg_N ("discrete type required for index", I); - Set_Etype (I, Any_Type); + Error_Msg_N ("discrete type required for index", N); + Set_Etype (N, Any_Type); return; end if; end if; if Expander_Active then - Rewrite (I, - Make_Attribute_Reference (Sloc (I), + Rewrite (N, + Make_Attribute_Reference (Sloc (N), Attribute_Name => Name_Range, - Prefix => Relocate_Node (I))); + Prefix => Relocate_Node (N))); -- The original was a subtype mark that does not freeze. This -- means that the rewritten version must not freeze either. - Set_Must_Not_Freeze (I); - Set_Must_Not_Freeze (Prefix (I)); - Analyze_And_Resolve (I); - T := Etype (I); - R := I; + Set_Must_Not_Freeze (N); + Set_Must_Not_Freeze (Prefix (N)); + Analyze_And_Resolve (N); + T := Etype (N); + R := N; -- If expander is inactive, type is legal, nothing else to construct @@ -17318,12 +17439,12 @@ package body Sem_Ch3 is end if; if not Is_Discrete_Type (T) then - Error_Msg_N ("discrete type required for range", I); - Set_Etype (I, Any_Type); + Error_Msg_N ("discrete type required for range", N); + Set_Etype (N, Any_Type); return; elsif T = Any_Type then - Set_Etype (I, Any_Type); + Set_Etype (N, Any_Type); return; end if; @@ -17365,12 +17486,16 @@ package body Sem_Ch3 is Set_Scalar_Range (Def_Id, R); Conditional_Delay (Def_Id, T); + if Nkind (N) = N_Subtype_Indication then + Inherit_Predicate_Flags (Def_Id, Entity (Subtype_Mark (N))); + end if; + -- In the subtype indication case, if the immediate parent of the -- new subtype is non-static, then the subtype we create is non- -- static, even if its bounds are static. - if Nkind (I) = N_Subtype_Indication - and then not Is_Static_Subtype (Entity (Subtype_Mark (I))) + if Nkind (N) = N_Subtype_Indication + and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) then Set_Is_Non_Static_Subtype (Def_Id); end if; @@ -17378,7 +17503,7 @@ package body Sem_Ch3 is -- Final step is to label the index with this constructed type - Set_Etype (I, Def_Id); + Set_Etype (N, Def_Id); end Make_Index; ------------------------------ @@ -17494,7 +17619,7 @@ package body Sem_Ch3 is -- Non-binary case elsif M_Val < 2 ** Bits then - Check_SPARK_Restriction ("modulus should be a power of 2", T); + Check_SPARK_05_Restriction ("modulus should be a power of 2", T); Set_Non_Binary_Modulus (T); if Bits > System_Max_Nonbinary_Modulus_Power then @@ -17823,12 +17948,20 @@ package body Sem_Ch3 is Related_Nod : Node_Id) is Id_B : constant Entity_Id := Base_Type (Id); - Full_B : constant Entity_Id := Full_View (Id_B); + Full_B : Entity_Id := Full_View (Id_B); Full : Entity_Id; begin if Present (Full_B) then + -- Get to the underlying full view if necessary + + if Is_Private_Type (Full_B) + and then Present (Underlying_Full_View (Full_B)) + then + Full_B := Underlying_Full_View (Full_B); + end if; + -- The Base_Type is already completed, we can complete the subtype -- now. We have to create a new entity with the same name, Thus we -- can't use Create_Itype. @@ -17919,10 +18052,12 @@ package body Sem_Ch3 is end if; end if; + -- Handling of discriminants that are access types + if Is_Access_Type (Discr_Type) then - -- Ada 2005 (AI-230): Access discriminant allowed in non-limited - -- record types + -- Ada 2005 (AI-230): Access discriminant allowed in non- + -- limited record types if Ada_Version < Ada_2005 then Check_Access_Discriminant_Requires_Limited @@ -17934,9 +18069,12 @@ package body Sem_Ch3 is ("(Ada 83) access discriminant not allowed", Discr); end if; + -- If not access type, must be a discrete type + elsif not Is_Discrete_Type (Discr_Type) then - Error_Msg_N ("discriminants must have a discrete or access type", - Discriminant_Type (Discr)); + Error_Msg_N + ("discriminants must have a discrete or access type", + Discriminant_Type (Discr)); end if; Set_Etype (Defining_Identifier (Discr), Discr_Type); @@ -17946,12 +18084,14 @@ package body Sem_Ch3 is -- expression of the discriminant; the default expression must be of -- the type of the discriminant. (RM 3.7.1) Since this expression is -- a default expression, we do the special preanalysis, since this - -- expression does not freeze (see "Handling of Default and Per- - -- Object Expressions" in spec of package Sem). + -- expression does not freeze (see section "Handling of Default and + -- Per-Object Expressions" in spec of package Sem). if Present (Expression (Discr)) then Preanalyze_Spec_Expression (Expression (Discr), Discr_Type); + -- Legaity checks + if Nkind (N) = N_Formal_Type_Declaration then Error_Msg_N ("discriminant defaults not allowed for formal type", @@ -17996,6 +18136,19 @@ package body Sem_Ch3 is (Defining_Identifier (Discr), Expression (Discr)); end if; + -- In gnatc or gnatprove mode, make sure set Do_Range_Check flag + -- gets set unless we can be sure that no range check is required. + + if (GNATprove_Mode or not Expander_Active) + and then not + Is_In_Range + (Expression (Discr), Discr_Type, Assume_Valid => True) + then + Set_Do_Range_Check (Expression (Discr)); + end if; + + -- No default discriminant value given + else Default_Not_Present := True; end if; @@ -18077,12 +18230,12 @@ package body Sem_Ch3 is end if; end if; - -- A discriminant cannot be volatile. This check is only relevant - -- when SPARK_Mode is on as it is not standard Ada legality rule - -- (SPARK RM 7.1.3(6)). + -- A discriminant cannot be effectively volatile. This check is only + -- relevant when SPARK_Mode is on as it is not standard Ada legality + -- rule (SPARK RM 7.1.3(6)). if SPARK_Mode = On - and then Is_SPARK_Volatile (Defining_Identifier (Discr)) + and then Is_Effectively_Volatile (Defining_Identifier (Discr)) then Error_Msg_N ("discriminant cannot be volatile", Discr); end if; @@ -18401,7 +18554,7 @@ package body Sem_Ch3 is if Priv_Parent /= Full_Parent then Error_Msg_Name_1 := Chars (Priv_Parent); - Check_SPARK_Restriction ("% expected", Full_Indic); + Check_SPARK_05_Restriction ("% expected", Full_Indic); end if; -- Check the rules of 7.3(10): if the private extension inherits @@ -18565,6 +18718,7 @@ package body Sem_Ch3 is declare Priv_Elmt : Elmt_Id; + Priv_Scop : Entity_Id; Priv : Entity_Id; Full : Entity_Id; @@ -18572,6 +18726,7 @@ package body Sem_Ch3 is Priv_Elmt := First_Elmt (Private_Dependents (Priv_T)); while Present (Priv_Elmt) loop Priv := Node (Priv_Elmt); + Priv_Scop := Scope (Priv); if Ekind_In (Priv, E_Private_Subtype, E_Limited_Private_Subtype, @@ -18585,10 +18740,26 @@ package body Sem_Ch3 is -- Now we need to complete the private subtype, but since the -- base type has already been swapped, we must also swap the -- subtypes (and thus, reverse the arguments in the call to - -- Complete_Private_Subtype). + -- Complete_Private_Subtype). Also note that we may need to + -- re-establish the scope of the private subtype. Copy_And_Swap (Priv, Full); + + if not In_Open_Scopes (Priv_Scop) then + Push_Scope (Priv_Scop); + + else + -- Reset Priv_Scop to Empty to indicate no scope was pushed + + Priv_Scop := Empty; + end if; + Complete_Private_Subtype (Full, Priv, Full_T, N); + + if Present (Priv_Scop) then + Pop_Scope; + end if; + Replace_Elmt (Priv_Elmt, Full); end if; @@ -18762,7 +18933,9 @@ 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_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T)); + Set_Has_Protected + (Class_Wide_Type (Priv_T), Has_Protected (Full_T)); end if; end; end if; @@ -18818,6 +18991,21 @@ 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. + + if Has_Inherited_Default_Init_Cond (Priv_T) then + Set_Has_Inherited_Default_Init_Cond (Full_T); + Set_Default_Init_Cond_Procedure + (Full_T, Default_Init_Cond_Procedure (Priv_T)); + + elsif Has_Default_Init_Cond (Priv_T) then + Set_Has_Default_Init_Cond (Full_T); + Set_Default_Init_Cond_Procedure + (Full_T, Default_Init_Cond_Procedure (Priv_T)); + end if; + -- Propagate invariants to full type if Has_Invariants (Priv_T) then @@ -18966,9 +19154,10 @@ package body Sem_Ch3 is procedure Process_Range_Expr_In_Decl (R : Node_Id; T : Entity_Id; - Check_List : List_Id := Empty_List; - R_Check_Off : Boolean := False; - In_Iter_Schm : Boolean := False) + Subtyp : Entity_Id := Empty; + Check_List : List_Id := Empty_List; + R_Check_Off : Boolean := False; + In_Iter_Schm : Boolean := False) is Lo, Hi : Node_Id; R_Checks : Check_Result; @@ -18984,9 +19173,9 @@ package body Sem_Ch3 is -- discrete type definition of a loop parameter specification. if not In_Iter_Schm - and then not Is_Static_Range (R) + and then not Is_OK_Static_Range (R) then - Check_SPARK_Restriction ("range should be static", R); + Check_SPARK_05_Restriction ("range should be static", R); end if; Lo := Low_Bound (R); @@ -19090,8 +19279,81 @@ package body Sem_Ch3 is -- not supposed to occur, e.g. on default parameters of a call. if Expander_Active or GNATprove_Mode then - Force_Evaluation (Lo); - Force_Evaluation (Hi); + + -- If no subtype name, then just call Force_Evaluation to + -- create declarations as needed to deal with side effects. + -- Also ignore calls from within a record type, where we + -- have possible scoping issues. + + if No (Subtyp) or else Is_Record_Type (Current_Scope) then + Force_Evaluation (Lo); + Force_Evaluation (Hi); + + -- If a subtype is given, then we capture the bounds if they + -- are not known at compile time, using constant identifiers + -- xxx_FIRST and xxx_LAST where xxx is the name of the subtype. + + -- Note: we do this transformation even if expansion is not + -- active, and in particular we do it in GNATprove_Mode since + -- the transformation is in general required to ensure that the + -- resulting tree has proper Ada semantics. + + -- Historical note: We used to just do Force_Evaluation calls + -- in all cases, but it is better to capture the bounds with + -- proper non-serialized names, since these will be accessed + -- from other units, and hence may be public, and also we can + -- then expand 'First and 'Last references to be references to + -- these special names. + + else + if not Compile_Time_Known_Value (Lo) + + -- No need to capture bounds if they already are + -- references to constants. + + and then not (Is_Entity_Name (Lo) + and then Is_Constant_Object (Entity (Lo))) + then + declare + Loc : constant Source_Ptr := Sloc (Lo); + Lov : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subtyp), "_FIRST")); + begin + Insert_Action (R, + Make_Object_Declaration (Loc, + Defining_Identifier => Lov, + Object_Definition => + New_Occurrence_Of (Base_Type (T), Loc), + Constant_Present => True, + Expression => Relocate_Node (Lo))); + Rewrite (Lo, New_Occurrence_Of (Lov, Loc)); + end; + end if; + + if not Compile_Time_Known_Value (Hi) + and then not (Is_Entity_Name (Hi) + and then Is_Constant_Object (Entity (Hi))) + then + declare + Loc : constant Source_Ptr := Sloc (Hi); + Hiv : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subtyp), "_LAST")); + begin + Insert_Action (R, + Make_Object_Declaration (Loc, + Defining_Identifier => Hiv, + Object_Definition => + New_Occurrence_Of (Base_Type (T), Loc), + Constant_Present => True, + Expression => Relocate_Node (Hi))); + Rewrite (Hi, New_Occurrence_Of (Hiv, Loc)); + end; + end if; + end if; end if; -- We use a flag here instead of suppressing checks on the @@ -19520,6 +19782,7 @@ package body Sem_Ch3 is when Enumeration_Kind => Constrain_Enumeration (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); when Ordinary_Fixed_Point_Kind => Constrain_Ordinary_Fixed (Def_Id, S); @@ -19529,6 +19792,7 @@ package body Sem_Ch3 is when Integer_Kind => Constrain_Integer (Def_Id, S); + Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id); when E_Record_Type | E_Record_Subtype | @@ -20013,6 +20277,18 @@ package body Sem_Ch3 is In_Assertion_Expr := In_Assertion_Expr - 1; end Preanalyze_Assert_Expression; + ----------------------------------- + -- Preanalyze_Default_Expression -- + ----------------------------------- + + procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id) is + Save_In_Default_Expr : constant Boolean := In_Default_Expr; + begin + In_Default_Expr := True; + Preanalyze_Spec_Expression (N, T); + In_Default_Expr := Save_In_Default_Expr; + end Preanalyze_Default_Expression; + -------------------------------- -- Preanalyze_Spec_Expression -- -------------------------------- @@ -20047,6 +20323,7 @@ package body Sem_Ch3 is Init_Size_Align (T); Set_Interfaces (T, No_Elist); Set_Stored_Constraint (T, No_Elist); + Set_Default_SSO (T); -- Normal case @@ -20054,11 +20331,11 @@ package body Sem_Ch3 is or else not Interface_Present (Def) then if Limited_Present (Def) then - Check_SPARK_Restriction ("limited is not allowed", N); + Check_SPARK_05_Restriction ("limited is not allowed", N); end if; if Abstract_Present (Def) then - Check_SPARK_Restriction ("abstract is not allowed", N); + Check_SPARK_05_Restriction ("abstract is not allowed", N); end if; -- The flag Is_Tagged_Type might have already been set by @@ -20080,7 +20357,7 @@ package body Sem_Ch3 is or else Abstract_Present (Def)); else - Check_SPARK_Restriction ("interface is not allowed", N); + Check_SPARK_05_Restriction ("interface is not allowed", N); Is_Tagged := True; Analyze_Interface_Declaration (T, Def); @@ -20244,13 +20521,13 @@ package body Sem_Ch3 is if Nkind (Ctxt) = N_Package_Body and then Nkind (Parent (Ctxt)) = N_Compilation_Unit then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("type should be defined in package specification", Typ); elsif Nkind (Ctxt) /= N_Package_Specification or else Nkind (Parent (Parent (Ctxt))) /= N_Compilation_Unit then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("type should be defined in library unit package", Typ); end if; end; @@ -20279,14 +20556,14 @@ package body Sem_Ch3 is or else Null_Present (Component_List (Def)) then if not Is_Tagged_Type (T) then - Check_SPARK_Restriction ("non-tagged record cannot be null", Def); + Check_SPARK_05_Restriction ("untagged record cannot be null", Def); end if; else Analyze_Declarations (Component_Items (Component_List (Def))); if Present (Variant_Part (Component_List (Def))) then - Check_SPARK_Restriction ("variant part is not allowed", Def); + Check_SPARK_05_Restriction ("variant part is not allowed", Def); Analyze (Variant_Part (Component_List (Def))); end if; end if; @@ -20309,6 +20586,10 @@ package body Sem_Ch3 is Set_Has_Task (T); end if; + if Has_Protected (Etype (Component)) then + Set_Has_Protected (T); + end if; + if Ekind (Component) /= E_Component then null; @@ -20409,6 +20690,24 @@ package body Sem_Ch3 is end Set_Completion_Referenced; --------------------- + -- Set_Default_SSO -- + --------------------- + + procedure Set_Default_SSO (T : Entity_Id) is + begin + case Opt.Default_SSO is + when ' ' => + null; + when 'L' => + Set_SSO_Set_Low_By_Default (T, True); + when 'H' => + Set_SSO_Set_High_By_Default (T, True); + when others => + raise Program_Error; + end case; + end Set_Default_SSO; + + --------------------- -- Set_Fixed_Range -- --------------------- @@ -20492,7 +20791,7 @@ package body Sem_Ch3 is -- catch possible premature use in the bounds themselves. Set_Ekind (Def_Id, E_Void); - Process_Range_Expr_In_Decl (R, Subt); + Process_Range_Expr_In_Decl (R, Subt, Subtyp => Def_Id); Set_Ekind (Def_Id, Kind); end Set_Scalar_Range_For_Subtype; diff --git a/main/gcc/ada/sem_ch3.ads b/main/gcc/ada/sem_ch3.ads index a0b37ea0a5b..57184ed58ad 100644 --- a/main/gcc/ada/sem_ch3.ads +++ b/main/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,18 +50,18 @@ package Sem_Ch3 is (Related_Nod : Node_Id; N : Node_Id) return Entity_Id; -- An access definition defines a general access type for a formal - -- parameter. The procedure is called when processing formals, when - -- the current scope is the subprogram. The Implicit type is attached - -- to the Related_Nod put into the enclosing scope, so that the only - -- entities defined in the spec are the formals themselves. + -- parameter. The procedure is called when processing formals, when the + -- current scope is the subprogram. The Implicit type is attached to the + -- Related_Nod put into the enclosing scope, so that the only entities + -- defined in the spec are the formals themselves. procedure Access_Subprogram_Declaration (T_Name : Entity_Id; T_Def : Node_Id); -- The subprogram specification yields the signature of an implicit - -- type, whose Ekind is Access_Subprogram_Type. This implicit type is - -- the designated type of the declared access type. In subprogram calls, - -- the signature of the implicit type works like the profile of a regular + -- type, whose Ekind is Access_Subprogram_Type. This implicit type is the + -- designated type of the declared access type. In subprogram calls, the + -- signature of the implicit type works like the profile of a regular -- subprogram. procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id); @@ -94,8 +94,8 @@ package Sem_Ch3 is -- enclosing declaration that generated Ityp. -- -- A related mechanism is used during expansion, for itypes created in - -- branches of conditionals. See Ensure_Defined in exp_util. - -- Could both mechanisms be merged ??? + -- branches of conditionals. See Ensure_Defined in exp_util. Could both + -- mechanisms be merged ??? procedure Check_Abstract_Overriding (T : Entity_Id); -- Check that all abstract subprograms inherited from T's parent type have @@ -126,11 +126,11 @@ package Sem_Ch3 is Parent_Type : Entity_Id; Actual_Subp : Entity_Id := Empty); -- Derive the subprogram Parent_Subp from Parent_Type, and replace the - -- subsidiary subtypes with the derived type to build the specification - -- of the inherited subprogram (returned in New_Subp). For tagged types, - -- the derived subprogram is aliased to that of the actual (in the - -- case where Actual_Subp is nonempty) rather than to the corresponding - -- subprogram of the parent type. + -- subsidiary subtypes with the derived type to build the specification of + -- the inherited subprogram (returned in New_Subp). For tagged types, the + -- derived subprogram is aliased to that of the actual (in the case where + -- Actual_Subp is nonempty) rather than to the corresponding subprogram of + -- the parent type. procedure Derive_Subprograms (Parent_Type : Entity_Id; @@ -183,25 +183,25 @@ package Sem_Ch3 is (C : Entity_Id; N : Node_Id := Empty) return Boolean; -- Determines if a record component C is visible in the present context. - -- Note that even though component C could appear in the entity chain - -- of a record type, C may not be visible in the current context. For - -- instance, C may be a component inherited in the full view of a private - -- extension which is not visible in the current context. + -- Note that even though component C could appear in the entity chain of a + -- record type, C may not be visible in the current context. For instance, + -- C may be a component inherited in the full view of a private extension + -- which is not visible in the current context. -- -- If present, N is the selected component of which C is the selector. If -- the prefix of N is a type conversion inserted for a discriminant check, -- C is automatically visible. procedure Make_Index - (I : Node_Id; + (N : Node_Id; Related_Nod : Node_Id; Related_Id : Entity_Id := Empty; - Suffix_Index : Nat := 1; - In_Iter_Schm : Boolean := False); + Suffix_Index : Nat := 1; + In_Iter_Schm : Boolean := False); -- Process an index that is given in an array declaration, an entry - -- family declaration or a loop iteration. The index is given by an - -- index declaration (a 'box'), or by a discrete range. The later can - -- be the name of a discrete type, or a subtype indication. + -- family declaration or a loop iteration. The index is given by an index + -- declaration (a 'box'), or by a discrete range. The later can be the name + -- of a discrete type, or a subtype indication. -- -- Related_Nod is the node where the potential generated implicit types -- will be inserted. The next last parameters are used for creating the @@ -250,6 +250,10 @@ package Sem_Ch3 is -- Wrapper on Preanalyze_Spec_Expression for assertion expressions, so that -- In_Assertion_Expr can be properly adjusted. + procedure Preanalyze_Default_Expression (N : Node_Id; T : Entity_Id); + -- Wrapper on Preanalyze_Spec_Expression for default expressions, so that + -- In_Default_Expr can be properly adjusted. + procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); -- Process some semantic actions when the full view of a private type is -- encountered and analyzed. The first action is to create the full views @@ -257,16 +261,17 @@ package Sem_Ch3 is -- primitive operations of the private view (in the tagged case). -- N is the N_Full_Type_Declaration node. -- - -- Full_T is the full view of the type whose full declaration is in N. + -- Full_T is the full view of the type whose full declaration is in N. -- - -- Priv_T is the private view of the type whose full declaration is in N. + -- Priv_T is the private view of the type whose full declaration is in N. procedure Process_Range_Expr_In_Decl (R : Node_Id; T : Entity_Id; - Check_List : List_Id := Empty_List; - R_Check_Off : Boolean := False; - In_Iter_Schm : Boolean := False); + Subtyp : Entity_Id := Empty; + Check_List : List_Id := Empty_List; + R_Check_Off : Boolean := False; + In_Iter_Schm : Boolean := False); -- Process a range expression that appears in a declaration context. The -- range is analyzed and resolved with the base type of the given type, and -- an appropriate check for expressions in non-static contexts made on the @@ -279,6 +284,9 @@ package Sem_Ch3 is -- package. R_Check_Off is set to True when the call to Range_Check is to -- be skipped. In_Iter_Schm is True if Process_Range_Expr_In_Decl is called -- on the discrete subtype definition in an iteration scheme. + -- + -- If Subtyp is given, then the range is for the named subtype Subtyp, and + -- in this case the bounds are captured if necessary using this name. function Process_Subtype (S : Node_Id; @@ -294,12 +302,12 @@ package Sem_Ch3 is (N : Node_Id; Prev : Entity_Id := Empty); -- Process the discriminants contained in an N_Full_Type_Declaration or - -- N_Incomplete_Type_Decl node N. If the declaration is a completion, - -- Prev is entity on the partial view, on which references are posted. - -- However, note that Process_Discriminants is called for a completion only - -- if partial view had no discriminants (else we just check conformance - -- between the two views and do not call Process_Discriminants again for - -- the completion). + -- N_Incomplete_Type_Decl node N. If the declaration is a completion, Prev + -- is entity on the partial view, on which references are posted. However, + -- note that Process_Discriminants is called for a completion only if + -- partial view had no discriminants (else we just check conformance + -- between the two views and do not call Process_Discriminants again + -- for the completion). function Replace_Anonymous_Access_To_Protected_Subprogram (N : Node_Id) return Entity_Id; diff --git a/main/gcc/ada/sem_ch4.adb b/main/gcc/ada/sem_ch4.adb index 3dc457d5956..6c260313c9c 100644 --- a/main/gcc/ada/sem_ch4.adb +++ b/main/gcc/ada/sem_ch4.adb @@ -74,17 +74,17 @@ package body Sem_Ch4 is -- operand has been analyzed. See Analyze_Concatenation for details. procedure Analyze_Expression (N : Node_Id); - -- For expressions that are not names, this is just a call to analyze. - -- If the expression is a name, it may be a call to a parameterless - -- function, and if so must be converted into an explicit call node - -- and analyzed as such. This deproceduring must be done during the first - -- pass of overload resolution, because otherwise a procedure call with - -- overloaded actuals may fail to resolve. + -- For expressions that are not names, this is just a call to analyze. If + -- the expression is a name, it may be a call to a parameterless function, + -- and if so must be converted into an explicit call node and analyzed as + -- such. This deproceduring must be done during the first pass of overload + -- resolution, because otherwise a procedure call with overloaded actuals + -- may fail to resolve. procedure Analyze_Operator_Call (N : Node_Id; Op_Id : Entity_Id); - -- Analyze a call of the form "+"(x, y), etc. The prefix of the call - -- is an operator name or an expanded name whose selector is an operator - -- name, and one possible interpretation is as a predefined operator. + -- Analyze a call of the form "+"(x, y), etc. The prefix of the call is an + -- operator name or an expanded name whose selector is an operator name, + -- and one possible interpretation is as a predefined operator. procedure Analyze_Overloaded_Selected_Component (N : Node_Id); -- If the prefix of a selected_component is overloaded, the proper @@ -132,7 +132,7 @@ package body Sem_Ch4 is procedure Check_Misspelled_Selector (Prefix : Entity_Id; Sel : Node_Id); - -- Give possible misspelling diagnostic if Sel is likely to be a mis- + -- Give possible misspelling message if Sel seems likely to be a mis- -- spelling of one of the selectors of the Prefix. This is called by -- Analyze_Selected_Component after producing an invalid selector error -- message. @@ -147,16 +147,16 @@ package body Sem_Ch4 is (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); - -- L and R are the operands of an arithmetic operator. Find - -- consistent pairs of interpretations for L and R that have a - -- numeric type consistent with the semantics of the operator. + -- L and R are the operands of an arithmetic operator. Find consistent + -- pairs of interpretations for L and R that have a numeric type consistent + -- with the semantics of the operator. procedure Find_Comparison_Types (L, R : Node_Id; Op_Id : Entity_Id; N : Node_Id); - -- L and R are operands of a comparison operator. Find consistent - -- pairs of interpretations for L and R. + -- L and R are operands of a comparison operator. Find consistent pairs of + -- interpretations for L and R. procedure Find_Concatenation_Types (L, R : Node_Id; @@ -403,7 +403,7 @@ package body Sem_Ch4 is Onode : Node_Id; begin - Check_SPARK_Restriction ("allocator is not allowed", N); + Check_SPARK_05_Restriction ("allocator is not allowed", N); -- Deal with allocator restrictions @@ -501,8 +501,6 @@ package body Sem_Ch4 is Type_Id := Etype (E); Set_Directly_Designated_Type (Acc_Type, Type_Id); - Resolve (Expression (E), Type_Id); - -- Allocators generated by the build-in-place expansion mechanism -- are explicitly marked as coming from source but do not need to be -- checked for limited initialization. To exclude this case, ensure @@ -529,10 +527,9 @@ package body Sem_Ch4 is -- Wrong_Type (Expression (E), Type_Id); -- end if; - Check_Non_Static_Context (Expression (E)); - -- We don't analyze the qualified expression itself because it's - -- part of the allocator + -- part of the allocator. It is fully analyzed and resolved when + -- the allocator is resolved with the context type. Set_Etype (E, Type_Id); @@ -639,15 +636,6 @@ package body Sem_Ch4 is end; end if; - -- Check restriction against dynamically allocated protected - -- objects. Note that when limited aggregates are supported, - -- a similar test should be applied to an allocator with a - -- qualified expression ??? - - if Is_Protected_Type (Type_Id) then - Check_Restriction (No_Protected_Type_Allocators, N); - end if; - -- Check for missing initialization. Skip this check if we already -- had errors on analyzing the allocator, since in that case these -- are probably cascaded errors. @@ -725,6 +713,12 @@ package body Sem_Ch4 is Check_Restriction (No_Task_Allocators, N); end if; + -- Check restriction against dynamically allocated protected objects + + if Has_Protected (Designated_Type (Acc_Type)) then + Check_Restriction (No_Protected_Type_Allocators, N); + end if; + -- AI05-0013-1: No_Nested_Finalization forbids allocators if the access -- type is nested, and the designated type needs finalization. The rule -- is conservative in that class-wide types need finalization. @@ -737,11 +731,8 @@ package body Sem_Ch4 is -- Check that an allocator of a nested access type doesn't create a -- protected object when restriction No_Local_Protected_Objects applies. - -- We don't have an equivalent to Has_Task for protected types, so only - -- cases where the designated type itself is a protected type are - -- currently checked. ??? - if Is_Protected_Type (Designated_Type (Acc_Type)) + if Has_Protected (Designated_Type (Acc_Type)) and then not Is_Library_Level_Entity (Acc_Type) then Check_Restriction (No_Local_Protected_Objects, N); @@ -945,7 +936,7 @@ package body Sem_Ch4 is case Nkind (Actual) is when N_Parameter_Association => if Named_Seen then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("named association cannot follow positional one", Actual); exit; @@ -1372,6 +1363,9 @@ package body Sem_Ch4 is Others_Present : Boolean; -- Indicates if Others was present + Wrong_Alt : Node_Id; + -- For error reporting + -- Start of processing for Analyze_Case_Expression begin @@ -1424,6 +1418,9 @@ package body Sem_Ch4 is if No (Alt) then Add_One_Interp (N, It.Typ, It.Typ); + + else + Wrong_Alt := Alt; end if; Get_Next_Interp (I, It); @@ -1444,12 +1441,21 @@ package body Sem_Ch4 is if Exp_Btype = Any_Discrete or else Exp_Btype = Any_Type then return; + -- Special casee message for character literal + elsif Exp_Btype = Any_Character then Error_Msg_N ("character literal as case expression is ambiguous", Expr); return; end if; + if Etype (N) = Any_Type and then Present (Wrong_Alt) then + Error_Msg_N + ("type incompatible with that of previous alternatives", + Expression (Wrong_Alt)); + return; + end if; + -- If the case expression is a formal object of mode in out, then -- treat it as having a nonstatic subtype by forcing use of the base -- type (which has to get passed to Check_Case_Choices below). Also @@ -1467,7 +1473,7 @@ package body Sem_Ch4 is -- case expression has not been fully analyzed yet because this may lead -- to bogus errors. - if Is_Static_Subtype (Exp_Type) + if Is_OK_Static_Subtype (Exp_Type) and then Has_Static_Predicate_Aspect (Exp_Type) and then In_Spec_Expression then @@ -1827,7 +1833,7 @@ package body Sem_Ch4 is -- source node check, because ??? if Comes_From_Source (N) then - Check_SPARK_Restriction ("explicit dereference is not allowed", N); + Check_SPARK_05_Restriction ("explicit dereference is not allowed", N); end if; -- In formal verification mode, keep track of all reads and writes @@ -2046,7 +2052,7 @@ package body Sem_Ch4 is end if; if Comes_From_Source (N) then - Check_SPARK_Restriction ("if expression is not allowed", N); + Check_SPARK_05_Restriction ("if expression is not allowed", N); end if; Else_Expr := Next (Then_Expr); @@ -2055,7 +2061,18 @@ package body Sem_Ch4 is Check_Compiler_Unit ("if expression", N); end if; + -- Analyze and resolve the condition. We need to resolve this now so + -- that it gets folded to True/False if possible, before we analyze + -- the THEN/ELSE branches, because when analyzing these branches, we + -- may call Is_Statically_Unevaluated, which expects the condition of + -- an enclosing IF to have been analyze/resolved/evaluated. + Analyze_Expression (Condition); + Resolve (Condition, Any_Boolean); + + -- Analyze THEN expression and (if present) ELSE expression. For those + -- we delay resolution in the normal manner, because of overloading etc. + Analyze_Expression (Then_Expr); if Present (Else_Expr) then @@ -2870,7 +2887,7 @@ package body Sem_Ch4 is procedure Analyze_Null (N : Node_Id) is begin - Check_SPARK_Restriction ("null is not allowed", N); + Check_SPARK_05_Restriction ("null is not allowed", N); Set_Etype (N, Any_Access); end Analyze_Null; @@ -3185,10 +3202,9 @@ package body Sem_Ch4 is then -- 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, as is the case in VMS_64. In this - -- case the use of literals is illegal, except in the body of - -- descendents of system, where arithmetic operations on - -- address are of course used. + -- visibly an integer type. In this case the use of literals is + -- illegal, except in the body of descendents of system, where + -- arithmetic operations on address are of course used. if Has_Compatible_Type (Actual, Etype (Formal)) and then @@ -3648,7 +3664,7 @@ package body Sem_Ch4 is -- Start of processing for Analyze_Quantified_Expression begin - Check_SPARK_Restriction ("quantified expression is not allowed", N); + Check_SPARK_05_Restriction ("quantified expression is not allowed", N); -- Create a scope to emulate the loop-like behavior of the quantified -- expression. The scope is needed to provide proper visibility of the @@ -4645,6 +4661,7 @@ package body Sem_Ch4 is end loop; if Present (Par) and then Is_Generic_Actual_Type (Par) then + -- Now look for component in ancestor types Par := Generic_Parent_Type (Declaration_Node (Par)); @@ -4654,6 +4671,14 @@ package body Sem_Ch4 is or else Par = Etype (Par); Par := Etype (Par); end loop; + + -- In ASIS mode the generic parent type may be absent. Examine + -- the parent type directly for a component that may have been + -- visible in a parent generic unit. + + elsif Is_Derived_Type (Prefix_Type) then + Par := Etype (Prefix_Type); + Find_Component_In_Instance (Par); end if; end; @@ -4663,6 +4688,7 @@ package body Sem_Ch4 is if No (Entity (Sel)) then raise Program_Error; end if; + return; -- Component not found, specialize error message when appropriate @@ -4851,7 +4877,7 @@ package body Sem_Ch4 is begin if Comes_From_Source (N) then - Check_SPARK_Restriction ("slice is not allowed", N); + Check_SPARK_05_Restriction ("slice is not allowed", N); end if; Analyze (P); @@ -4932,9 +4958,9 @@ package body Sem_Ch4 is -- error message. Conversely, constant-folding in the generic may -- transform the argument of a conversion into a string literal, which -- is legal. Therefore the following tests are not performed in an - -- instance. + -- instance. The same applies to an inlined body. - elsif In_Instance then + elsif In_Instance or In_Inlined_Body then return; elsif Nkind (Expr) = N_Null then @@ -6446,11 +6472,16 @@ package body Sem_Ch4 is if Address_Integer_Convert_OK (Etype (R), Etype (L)) then Rewrite (R, Unchecked_Convert_To (Etype (L), Relocate_Node (R))); - Analyze_Arithmetic_Op (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; else Resolve (R, Etype (L)); end if; + return; elsif Is_Numeric_Type (Etype (R)) @@ -6459,7 +6490,13 @@ package body Sem_Ch4 is if Address_Integer_Convert_OK (Etype (L), Etype (R)) then Rewrite (L, Unchecked_Convert_To (Etype (R), Relocate_Node (L))); - Analyze_Arithmetic_Op (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; else @@ -6483,7 +6520,12 @@ package body Sem_Ch4 is Rewrite (R, Unchecked_Convert_To ( Standard_Integer, Relocate_Node (R))); - Analyze_Arithmetic_Op (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; -- If this is an operand in an enclosing arithmetic -- operation, Convert the result as an address so that @@ -6558,6 +6600,14 @@ package body Sem_Ch4 is end if; return; + + elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then + if Address_Integer_Convert_OK (Etype (R), Etype (L)) then + Rewrite (R, + Unchecked_Convert_To (Etype (L), Relocate_Node (R))); + Analyze_Equality_Op (N); + return; + end if; end if; -- If we fall through then just give general message. Note that in @@ -6805,9 +6855,8 @@ package body Sem_Ch4 is -- Remove interpretations that treat literals as addresses. This -- is never appropriate, even when Address is defined as a visible -- Integer type. The reason is that we would really prefer Address - -- to behave as a private type, even in this case, which is there - -- only to accommodate oddities of VMS address sizes. If Address - -- is a visible integer type, we get lots of overload ambiguities. + -- to behave as a private type, even in this case. If Address is a + -- visible integer type, we get lots of overload ambiguities. if Nkind (N) in N_Binary_Op then declare @@ -6957,6 +7006,7 @@ package body Sem_Ch4 is Exprs : List_Id) return Boolean is Loc : constant Source_Ptr := Sloc (N); + C_Type : Entity_Id; Assoc : List_Id; Disc : Entity_Id; Func : Entity_Id; @@ -6964,6 +7014,14 @@ package body Sem_Ch4 is Indexing : Node_Id; begin + C_Type := Etype (Prefix); + + -- If indexing a class-wide container, obtain indexing primitive + -- from specific type. + + if Is_Class_Wide_Type (C_Type) then + C_Type := Etype (Base_Type (C_Type)); + end if; -- Check whether type has a specified indexing aspect @@ -7011,10 +7069,10 @@ package body Sem_Ch4 is -- Additional machinery may be needed for types that have several user- -- defined Reference operations with different signatures ??? - elsif Is_Derived_Type (Etype (Prefix)) + elsif Is_Derived_Type (C_Type) and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix) then - Func := Find_Prim_Op (Etype (Prefix), Chars (Func_Name)); + Func := Find_Prim_Op (C_Type, Chars (Func_Name)); Func_Name := New_Occurrence_Of (Func, Loc); end if; @@ -7548,6 +7606,18 @@ package body Sem_Ch4 is Save_Interps (Subprog, Node_To_Replace); else + -- The type of the subprogram may be a limited view obtained + -- transitively from another unit. If full view is available, + -- use it to analyze call. + + declare + T : constant Entity_Id := Etype (Subprog); + begin + if From_Limited_With (T) then + Set_Etype (Entity (Subprog), Available_View (T)); + end if; + end; + Analyze (Node_To_Replace); -- If the operation has been rewritten into a call, which may get @@ -7593,7 +7663,7 @@ package body Sem_Ch4 is if Nkind (Parent (Op)) = N_Full_Type_Declaration then Error_Msg_N ("\possible interpretation " - & "( inherited, with implicit dereference) #", N); + & "(inherited, with implicit dereference) #", N); else Error_Msg_N ("\possible interpretation (with implicit dereference) #", N); diff --git a/main/gcc/ada/sem_ch5.adb b/main/gcc/ada/sem_ch5.adb index d90a7e534cb..b80efcec704 100644 --- a/main/gcc/ada/sem_ch5.adb +++ b/main/gcc/ada/sem_ch5.adb @@ -893,7 +893,7 @@ package body Sem_Ch5 is -- block statements generated by the expander is fine. if Nkind (Original_Node (N)) = N_Block_Statement then - Check_SPARK_Restriction ("block statement is not allowed", N); + Check_SPARK_05_Restriction ("block statement is not allowed", N); end if; -- If no handled statement sequence is present, things are really messed @@ -1212,7 +1212,7 @@ package body Sem_Ch5 is -- Case statement with single OTHERS alternative not allowed in SPARK if Others_Present and then List_Length (Alternatives (N)) = 1 then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("OTHERS as unique case alternative is not allowed", N); end if; @@ -1299,7 +1299,7 @@ package body Sem_Ch5 is else if Has_Loop_In_Inner_Open_Scopes (U_Name) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("exit label must name the closest enclosing loop", N); end if; @@ -1343,34 +1343,34 @@ package body Sem_Ch5 is if Present (Cond) then if Nkind (Parent (N)) /= N_Loop_Statement then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("exit with when clause must be directly in loop", N); end if; else if Nkind (Parent (N)) /= N_If_Statement then if Nkind (Parent (N)) = N_Elsif_Part then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("exit must be in IF without ELSIF", N); else - Check_SPARK_Restriction ("exit must be directly in IF", N); + Check_SPARK_05_Restriction ("exit must be directly in IF", N); end if; elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("exit must be in IF directly in loop", N); -- First test the presence of ELSE, so that an exit in an ELSE leads -- to an error mentioning the ELSE. elsif Present (Else_Statements (Parent (N))) then - Check_SPARK_Restriction ("exit must be in IF without ELSE", N); + Check_SPARK_05_Restriction ("exit must be in IF without ELSE", N); -- An exit in an ELSIF does not reach here, as it would have been -- detected in the case (Nkind (Parent (N)) /= N_If_Statement). elsif Present (Elsif_Parts (Parent (N))) then - Check_SPARK_Restriction ("exit must be in IF without ELSIF", N); + Check_SPARK_05_Restriction ("exit must be in IF without ELSIF", N); end if; end if; @@ -1398,7 +1398,7 @@ package body Sem_Ch5 is Label_Ent : Entity_Id; begin - Check_SPARK_Restriction ("goto statement is not allowed", N); + Check_SPARK_05_Restriction ("goto statement is not allowed", N); -- Actual semantic checks @@ -1698,6 +1698,28 @@ package body Sem_Ch5 is 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 + -- implements the reversible iterator interface. + + ----------------------------- + -- Check_Reverse_Iteration -- + ----------------------------- + + procedure Check_Reverse_Iteration (Typ : Entity_Id) is + begin + if Reverse_Present (N) + and then not Is_Array_Type (Typ) + and then not Is_Reversible_Iterator (Typ) + then + Error_Msg_NE + ("container type does not support reverse iteration", N, Typ); + end if; + end Check_Reverse_Iteration; + + -- Start of processing for Analyze_iterator_Specification + begin Enter_Name (Def_Id); @@ -1725,6 +1747,46 @@ package body Sem_Ch5 is if Of_Present (N) then Set_Related_Expression (Def_Id, Iter_Name); + + -- For a container, the iterator is specified through the aspect. + + if not Is_Array_Type (Etype (Iter_Name)) then + declare + Iterator : constant Entity_Id := + Find_Value_Of_Aspect + (Etype (Iter_Name), Aspect_Default_Iterator); + + I : Interp_Index; + It : Interp; + + begin + if No (Iterator) then + null; -- error reported below. + + elsif not Is_Overloaded (Iterator) then + Check_Reverse_Iteration (Etype (Iterator)); + + -- If Iterator is overloaded, use reversible iterator if + -- one is available. + + elsif Is_Overloaded (Iterator) then + Get_First_Interp (Iterator, I, It); + while Present (It.Nam) loop + if Ekind (It.Nam) = E_Function + and then Is_Reversible_Iterator (Etype (It.Nam)) + then + Set_Etype (Iterator, It.Typ); + Set_Entity (Iterator, It.Nam); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + + Check_Reverse_Iteration (Etype (Iterator)); + end if; + end; + end if; end if; -- If the domain of iteration is an expression, create a declaration for @@ -1750,11 +1812,33 @@ package body Sem_Ch5 is and then not ASIS_Mode then declare - Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); - Decl : Node_Id; + Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name); + Decl : Node_Id; + Act_S : Node_Id; begin - Typ := Etype (Iter_Name); + + -- If the domain of iteration is an array component that depends + -- on a discriminant, create actual subtype for it. Pre-analysis + -- does not generate the actual subtype of a selected component. + + if Nkind (Iter_Name) = N_Selected_Component + and then Is_Array_Type (Etype (Iter_Name)) + then + Act_S := + Build_Actual_Subtype_Of_Component + (Etype (Selector_Name (Iter_Name)), Iter_Name); + Insert_Action (N, Act_S); + + if Present (Act_S) then + Typ := Defining_Identifier (Act_S); + else + Typ := Etype (Iter_Name); + end if; + + else + Typ := Etype (Iter_Name); + end if; -- Protect against malformed iterator @@ -1763,6 +1847,10 @@ package body Sem_Ch5 is return; end if; + if not Of_Present (N) then + Check_Reverse_Iteration (Typ); + end if; + -- The name in the renaming declaration may be a function call. -- Indicate that it does not come from source, to suppress -- spurious warnings on renamings of parameterless functions, @@ -1824,6 +1912,10 @@ package body Sem_Ch5 is else Resolve (Iter_Name, Etype (Iter_Name)); end if; + + if not Of_Present (N) then + Check_Reverse_Iteration (Etype (Iter_Name)); + end if; end if; -- Get base type of container, for proper retrieval of Cursor type @@ -1985,16 +2077,16 @@ package body Sem_Ch5 is end if; end if; - -- A loop parameter cannot be volatile. This check is peformed only - -- when SPARK_Mode is on as it is not a standard Ada legality check - -- (SPARK RM 7.1.3(6)). + -- A loop parameter cannot be effectively volatile. This check is + -- peformed only when SPARK_Mode is on as it is not a standard Ada + -- legality check (SPARK RM 7.1.3(6)). -- 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_SPARK_Volatile (Ent) + and then Is_Effectively_Volatile (Ent) then Error_Msg_N ("loop parameter cannot be volatile", Ent); end if; @@ -2042,6 +2134,12 @@ package body Sem_Ch5 is -- to capture the bounds, so that the function result can be finalized -- in timely fashion. + procedure Check_Predicate_Use (T : Entity_Id); + -- Diagnose Attempt to iterate through non-static predicate. Note that + -- a type with inherited predicates may have both static and dynamic + -- forms. In this case it is not sufficent to check the static predicate + -- function only, look for a dynamic predicate aspect as well. + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; -- N is the node for an arbitrary construct. This function searches the -- construct N to see if any expressions within it contain function @@ -2100,6 +2198,35 @@ package body Sem_Ch5 is end if; end Check_Controlled_Array_Attribute; + ------------------------- + -- Check_Predicate_Use -- + ------------------------- + + procedure Check_Predicate_Use (T : Entity_Id) is + begin + -- A predicated subtype is illegal in loops and related constructs + -- if the predicate is not static, or if it is a non-static subtype + -- of a statically predicated subtype. + + if Is_Discrete_Type (T) + and then Has_Predicates (T) + and then (not Has_Static_Predicate (T) + or else not Is_Static_Subtype (T) + or else Has_Dynamic_Predicate_Aspect (T)) + then + -- Seems a confusing message for the case of a static predicate + -- with a non-static subtype??? + + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static predicate for loop " + & "iteration", Discrete_Subtype_Definition (N), + T, Suggest_Static => True); + + elsif Inside_A_Generic and then Is_Generic_Formal (T) then + Set_No_Dynamic_Predicate_On_Actual (T); + end if; + end Check_Predicate_Use; + ------------------------------------ -- Has_Call_Using_Secondary_Stack -- ------------------------------------ @@ -2317,11 +2444,11 @@ package body Sem_Ch5 is -- Propagate staticness to loop range itself, in case the -- corresponding subtype is static. - if New_Lo /= Lo and then Is_Static_Expression (New_Lo) then + if New_Lo /= Lo and then Is_OK_Static_Expression (New_Lo) then Rewrite (Low_Bound (R), New_Copy (New_Lo)); end if; - if New_Hi /= Hi and then Is_Static_Expression (New_Hi) then + if New_Hi /= Hi and then Is_OK_Static_Expression (New_Hi) then Rewrite (High_Bound (R), New_Copy (New_Hi)); end if; end Process_Bounds; @@ -2362,7 +2489,7 @@ package body Sem_Ch5 is -- Loop parameter specification must include subtype mark in SPARK if Nkind (DS) = N_Range then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("loop parameter specification must include subtype mark", N); end if; @@ -2391,16 +2518,23 @@ 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 -- then it is an iteration over a container. It was classified as -- a loop specification by the parser, and must be rewritten now - -- to activate container iteration. + -- to activate container iteration. The last case will occur within + -- an expanded inlined call, where the expansion wraps an actual in + -- an unchecked conversion when needed. The expression of the + -- 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 Attribute_Name (DS_Copy) = Name_Old) + and then Nam_In (Attribute_Name (DS_Copy), + Name_Old, Name_Loop_Entry)) + or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion + or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable) then -- This is an iterator specification. Rewrite it as such and -- analyze it to capture function calls that may require @@ -2474,20 +2608,7 @@ package body Sem_Ch5 is Set_Etype (DS, Entity (DS)); end if; - -- Attempt to iterate through non-static predicate. Note that a type - -- with inherited predicates may have both static and dynamic forms. - -- In this case it is not sufficent to check the static predicate - -- function only, look for a dynamic predicate aspect as well. - - if Is_Discrete_Type (Entity (DS)) - and then Present (Predicate_Function (Entity (DS))) - and then (No (Static_Predicate (Entity (DS))) - or else Has_Dynamic_Predicate_Aspect (Entity (DS))) - then - Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static predicate for loop " & - "iteration", DS, Entity (DS), Suggest_Static => True); - end if; + Check_Predicate_Use (Entity (DS)); end if; -- Error if not discrete type @@ -2499,6 +2620,10 @@ package body Sem_Ch5 is Check_Controlled_Array_Attribute (DS); + if Nkind (DS) = N_Subtype_Indication then + Check_Predicate_Use (Entity (Subtype_Mark (DS))); + end if; + Make_Index (DS, N, In_Iter_Schm => True); Set_Ekind (Id, E_Loop_Parameter); @@ -2710,11 +2835,11 @@ package body Sem_Ch5 is end; end if; - -- A loop parameter cannot be volatile. This check is peformed only - -- when SPARK_Mode is on as it is not a standard Ada legality check - -- (SPARK RM 7.1.3(6)). + -- A loop parameter cannot be effectively volatile. This check is + -- peformed only when SPARK_Mode is on as it is not a standard Ada + -- legality check (SPARK RM 7.1.3(6)). - if SPARK_Mode = On and then Is_SPARK_Volatile (Id) then + if SPARK_Mode = On and then Is_Effectively_Volatile (Id) then Error_Msg_N ("loop parameter cannot be volatile", Id); end if; end Analyze_Loop_Parameter_Specification; @@ -2834,6 +2959,20 @@ package body Sem_Ch5 is raise Program_Error; end if; + -- 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 + Error_Msg_Sloc := Sloc (Ent); + Error_Msg_N ("implicit label declaration for & is hidden#", Id); + + if Present (Homonym (Ent)) + and then Ekind (Homonym (Ent)) = E_Label + then + Set_Entity (Id, Ent); + Set_Ekind (Ent, E_Loop); + end if; + else Generate_Reference (Ent, N, ' '); Generate_Definition (Ent); @@ -2978,24 +3117,38 @@ package body Sem_Ch5 is -- analyze the loop body now even in the Ada 2012 iterator case, since -- the rewriting will not be done. Insert the loop variable in the -- current scope, if not done when analysing the iteration scheme. + -- Set its kind properly to detect improper uses in the loop body. - if No (Iter) - or else No (Iterator_Specification (Iter)) - or else not Expander_Active + if Present (Iter) + and then Present (Iterator_Specification (Iter)) then - if Present (Iter) - and then Present (Iterator_Specification (Iter)) - then + if not Expander_Active then declare - Id : constant Entity_Id := - Defining_Identifier (Iterator_Specification (Iter)); + I_Spec : constant Node_Id := Iterator_Specification (Iter); + Id : constant Entity_Id := Defining_Identifier (I_Spec); + begin if Scope (Id) /= Current_Scope then Enter_Name (Id); end if; + + -- In an element iterator, The loop parameter is a variable if + -- the domain of iteration (container or array) is a variable. + + if not Of_Present (I_Spec) + or else not Is_Variable (Name (I_Spec)) + then + Set_Ekind (Id, E_Loop_Parameter); + end if; end; + + Analyze_Statements (Statements (N)); end if; + else + + -- Pre-Ada2012 for-loops and while loops. + Analyze_Statements (Statements (N)); end if; @@ -3182,16 +3335,21 @@ package body Sem_Ch5 is -- unreachable code, since it is useless and we don't -- want to generate junk warnings. - -- We skip this step if we are not in code generation mode. + -- We skip this step if we are not in code generation mode + -- or CodePeer mode. + -- This is the one case where we remove dead code in the -- semantics as opposed to the expander, and we do not want -- to remove code if we are not in code generation mode, - -- since this messes up the ASIS trees. + -- since this messes up the ASIS trees or loses useful + -- information in the CodePeer tree. -- Note that one might react by moving the whole circuit to -- exp_ch5, but then we lose the warning in -gnatc mode. - if Operating_Mode = Generate_Code then + if Operating_Mode = Generate_Code + and then not CodePeer_Mode + then loop Nxt := Next (N); @@ -3212,7 +3370,7 @@ package body Sem_Ch5 is -- Now issue the warning (or error in formal mode) if Restriction_Check_Required (SPARK_05) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("unreachable code is not allowed", Error_Node); else Error_Msg ("??unreachable code!", Sloc (Error_Node)); diff --git a/main/gcc/ada/sem_ch6.adb b/main/gcc/ada/sem_ch6.adb index bd9e4ec52ee..01c6e26b50c 100644 --- a/main/gcc/ada/sem_ch6.adb +++ b/main/gcc/ada/sem_ch6.adb @@ -40,6 +40,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; +with Inline; use Inline; with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; with Layout; use Layout; @@ -105,7 +106,7 @@ package body Sem_Ch6 is procedure Analyze_Null_Procedure (N : Node_Id; Is_Completion : out Boolean); - -- A null procedure can be a declaration or (Ada 2012) a completion. + -- A null procedure can be a declaration or (Ada 2012) a completion procedure Analyze_Return_Statement (N : Node_Id); -- Common processing for simple and extended return statements @@ -127,27 +128,9 @@ package body Sem_Ch6 is -- Analyze a generic subprogram body. N is the body to be analyzed, and -- Gen_Id is the defining entity Id for the corresponding spec. - procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id); - -- If a subprogram has pragma Inline and inlining is active, use generic - -- machinery to build an unexpanded body for the subprogram. This body is - -- subsequently used for inline expansions at call sites. If subprogram can - -- be inlined (depending on size and nature of local declarations) this - -- function returns true. Otherwise subprogram body is treated normally. - -- If proper warnings are enabled and the subprogram contains a construct - -- that cannot be inlined, the offending construct is flagged accordingly. - function Can_Override_Operator (Subp : Entity_Id) return Boolean; -- Returns true if Subp can override a predefined operator. - procedure Check_And_Build_Body_To_Inline - (N : Node_Id; - Spec_Id : Entity_Id; - Body_Id : Entity_Id); - -- Spec_Id and Body_Id are the entities of the specification and body of - -- the subprogram body N. If N can be inlined by the frontend (supported - -- cases documented in Check_Body_To_Inline) then build the body-to-inline - -- associated with N and attach it to the declaration node of Spec_Id. - procedure Check_Conformance (New_Id : Entity_Id; Old_Id : Entity_Id; @@ -230,7 +213,7 @@ package body Sem_Ch6 is Scop : constant Entity_Id := Current_Scope; begin - Check_SPARK_Restriction ("abstract subprogram is not allowed", N); + Check_SPARK_05_Restriction ("abstract subprogram is not allowed", N); Generate_Definition (Designator); Set_Contract (Designator, Make_Contract (Sloc (Designator))); @@ -283,7 +266,6 @@ package body Sem_Ch6 is -- declaration is completed. Def_Id is needed to analyze the spec. New_Body : Node_Id; - New_Decl : Node_Id; New_Spec : Node_Id; Ret : Node_Id; @@ -371,7 +353,12 @@ package body Sem_Ch6 is Analyze (New_Body); Set_Is_Inlined (Prev); - elsif Present (Prev) and then Comes_From_Source (Prev) then + -- If the expression function is a completion, the previous declaration + -- must come from source. We know already that appears in the current + -- scope. The entity itself may be internally created if within a body + -- to be inlined. + + elsif Present (Prev) and then Comes_From_Source (Parent (Prev)) then Set_Has_Completion (Prev, False); -- An expression function that is a completion freezes the @@ -451,10 +438,7 @@ package body Sem_Ch6 is ("an expression function is not a legal protected operation", N); end if; - New_Decl := - Make_Subprogram_Declaration (Loc, Specification => Spec); - - Rewrite (N, New_Decl); + Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec)); -- Correct the parent pointer of the aspect specification list to -- reference the rewritten node. @@ -464,7 +448,15 @@ package body Sem_Ch6 is end if; Analyze (N); - Set_Is_Inlined (Defining_Entity (New_Decl)); + Set_Is_Inlined (Defining_Entity (N)); + + -- Establish the linkages between the spec and the body. These are + -- used when the expression function acts as the prefix of attribute + -- 'Access in order to freeze the original expression which has been + -- moved to the generated body. + + Set_Corresponding_Body (N, Defining_Entity (New_Body)); + Set_Corresponding_Spec (New_Body, Defining_Entity (N)); -- To prevent premature freeze action, insert the new body at the end -- of the current declarations, or at the end of the package spec. @@ -478,37 +470,48 @@ package body Sem_Ch6 is declare Decls : List_Id := List_Containing (N); Par : constant Node_Id := Parent (Decls); - Id : constant Entity_Id := Defining_Entity (New_Decl); + Id : constant Entity_Id := Defining_Entity (N); begin - if Nkind (Par) = N_Package_Specification - and then Decls = Visible_Declarations (Par) - and then Present (Private_Declarations (Par)) - and then not Is_Empty_List (Private_Declarations (Par)) + -- If this is a wrapper created for in an instance for a formal + -- subprogram, insert body after declaration, to be analyzed when + -- the enclosing instance is analyzed. + + if GNATprove_Mode + and then Is_Generic_Actual_Subprogram (Defining_Entity (N)) then - Decls := Private_Declarations (Par); - end if; + Insert_After (N, New_Body); - Insert_After (Last (Decls), New_Body); - Push_Scope (Id); - Install_Formals (Id); + else + if Nkind (Par) = N_Package_Specification + and then Decls = Visible_Declarations (Par) + and then Present (Private_Declarations (Par)) + and then not Is_Empty_List (Private_Declarations (Par)) + then + Decls := Private_Declarations (Par); + end if; - -- Preanalyze the expression for name capture, except in an - -- instance, where this has been done during generic analysis, - -- and will be redone when analyzing the body. + Insert_After (Last (Decls), New_Body); + Push_Scope (Id); + Install_Formals (Id); - declare - Expr : constant Node_Id := Expression (Ret); + -- Preanalyze the expression for name capture, except in an + -- instance, where this has been done during generic analysis, + -- and will be redone when analyzing the body. - begin - Set_Parent (Expr, Ret); + declare + Expr : constant Node_Id := Expression (Ret); - if not In_Instance then - Preanalyze_Spec_Expression (Expr, Etype (Id)); - end if; - end; + begin + Set_Parent (Expr, Ret); - End_Scope; + if not In_Instance then + Preanalyze_Spec_Expression (Expr, Etype (Id)); + end if; + end; + + End_Scope; + end if; end; end if; @@ -629,8 +632,8 @@ package body Sem_Ch6 is and then not GNAT_Mode then Error_Msg_N - ("(Ada 2005) cannot copy object of a limited type " & - "(RM-2005 6.5(5.5/2))", Expr); + ("(Ada 2005) cannot copy object of a limited type " + & "(RM-2005 6.5(5.5/2))", Expr); if Is_Limited_View (R_Type) then Error_Msg_N @@ -720,7 +723,7 @@ package body Sem_Ch6 is if not Predicates_Match (R_Stm_Type, R_Type) then Error_Msg_Node_2 := R_Type; Error_Msg_NE - ("\predicate of & does not match predicate of &", + ("\predicate of& does not match predicate of&", N, R_Stm_Type); end if; end Error_No_Match; @@ -771,8 +774,8 @@ package body Sem_Ch6 is elsif R_Stm_Type_Is_Anon_Access and then not R_Type_Is_Anon_Access then - Error_Msg_N ("anonymous access not allowed for function with " & - "named access result", Subtype_Ind); + Error_Msg_N ("anonymous access not allowed for function with " + & "named access result", Subtype_Ind); -- Subtype indication case: check that the return object's type is -- covered by the result type, and that the subtypes statically match @@ -811,10 +814,11 @@ package body Sem_Ch6 is end if; end if; - elsif Etype (Base_Type (R_Type)) = R_Stm_Type - and then Is_Null_Extension (Base_Type (R_Type)) - then - null; + -- All remaining cases are illegal + + -- Note: previous versions of this subprogram allowed the return + -- value to be the ancestor of the return type if the return type + -- was a null extension. This was plainly incorrect. else Error_Msg_N @@ -878,12 +882,12 @@ package body Sem_Ch6 is (Nkind (Parent (Parent (N))) /= N_Subprogram_Body or else Present (Next (N))) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("RETURN should be the last statement in function", N); end if; else - Check_SPARK_Restriction ("extended RETURN is not allowed", N); + Check_SPARK_05_Restriction ("extended RETURN is not allowed", N); -- Analyze parts specific to extended_return_statement: @@ -938,8 +942,8 @@ package body Sem_Ch6 is & "in Ada 2012??", N); elsif not Is_Limited_View (R_Type) then - Error_Msg_N ("aliased only allowed for limited" - & " return objects", N); + Error_Msg_N + ("aliased only allowed for limited return objects", N); end if; end if; end; @@ -988,6 +992,14 @@ package body Sem_Ch6 is then Error_Msg_N ("cannot return local access to subprogram", N); end if; + + -- The expression cannot be of a formal incomplete type + + elsif Ekind (Etype (Expr)) = E_Incomplete_Type + and then Is_Generic_Type (Etype (Expr)) + then + Error_Msg_N + ("cannot return expression of a formal incomplete type", N); end if; -- If the result type is class-wide, then check that the return @@ -1001,8 +1013,8 @@ package body Sem_Ch6 is Subprogram_Access_Level (Scope_Id) then Error_Msg_N - ("level of return expression type is deeper than " & - "class-wide function!", Expr); + ("level of return expression type is deeper than " + & "class-wide function!", Expr); end if; end if; @@ -1239,8 +1251,6 @@ package body Sem_Ch6 is end loop; end; - Check_SPARK_Mode_In_Generic (N); - Set_SPARK_Pragma (Body_Id, SPARK_Mode_Pragma); Set_SPARK_Pragma_Inherited (Body_Id, True); @@ -1309,12 +1319,16 @@ package body Sem_Ch6 is -- Create new entities for body and formals Set_Defining_Unit_Name (Specification (Null_Body), - Make_Defining_Identifier (Loc, Chars (Defining_Entity (N)))); + Make_Defining_Identifier + (Sloc (Defining_Entity (N)), + Chars (Defining_Entity (N)))); Form := First (Parameter_Specifications (Specification (Null_Body))); while Present (Form) loop Set_Defining_Identifier (Form, - Make_Defining_Identifier (Loc, Chars (Defining_Identifier (Form)))); + Make_Defining_Identifier + (Sloc (Defining_Identifier (Form)), + Chars (Defining_Identifier (Form)))); Next (Form); end loop; @@ -1390,19 +1404,14 @@ package body Sem_Ch6 is end if; else - -- The null procedure is a completion + -- The null procedure is a completion. We unconditionally rewrite + -- this as a null body (even if expansion is not active), because + -- there are various error checks that are applied on this body + -- when it is analyzed (e.g. correct aspect placement). Is_Completion := True; - - if Expander_Active then - Rewrite (N, Null_Body); - Analyze (N); - - else - Designator := Analyze_Subprogram_Specification (Spec); - Set_Has_Completion (Designator); - Set_Has_Completion (Prev); - end if; + Rewrite (N, Null_Body); + Analyze (N); end if; end Analyze_Null_Procedure; @@ -1798,8 +1807,8 @@ package body Sem_Ch6 is else Error_Msg_N - ("return nested in extended return statement cannot return " & - "value (use `RETURN;`)", N); + ("return nested in extended return statement cannot return " + & "value (use `RETURN;`)", N); end if; end if; @@ -1850,7 +1859,7 @@ package body Sem_Ch6 is if Result_Definition (N) /= Error then if Nkind (Result_Definition (N)) = N_Access_Definition then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("access result is not allowed", Result_Definition (N)); -- Ada 2005 (AI-254): Handle anonymous access to subprograms @@ -1884,7 +1893,7 @@ package body Sem_Ch6 is -- Unconstrained array as result is not allowed in SPARK if Is_Array_Type (Typ) and then not Is_Constrained (Typ) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("returning an unconstrained array is not allowed", Result_Definition (N)); end if; @@ -1950,9 +1959,35 @@ package body Sem_Ch6 is then -- AI05-0151: Tagged incomplete types are allowed in all formal -- parts. Untagged incomplete types are not allowed in bodies. + -- As a consequence, limited views cannot appear in a basic + -- declaration that is itself within a body, because there is + -- no point at which the non-limited view will become visible. if Ada_Version >= Ada_2012 then - if Is_Tagged_Type (Typ) then + if From_Limited_With (Typ) and then In_Package_Body then + Error_Msg_NE + ("invalid use of incomplete type&", + Result_Definition (N), Typ); + + -- The return type of a subprogram body cannot be of a + -- formal incomplete type. + + elsif Is_Generic_Type (Typ) + and then Nkind (Parent (N)) = N_Subprogram_Body + then + Error_Msg_N + ("return type cannot be a formal incomplete type", + Result_Definition (N)); + + elsif Is_Class_Wide_Type (Typ) + and then Is_Generic_Type (Root_Type (Typ)) + and then Nkind (Parent (N)) = N_Subprogram_Body + then + Error_Msg_N + ("return type cannot be a formal incomplete type", + Result_Definition (N)); + + elsif Is_Tagged_Type (Typ) then null; elsif Nkind (Parent (N)) = N_Subprogram_Body @@ -2093,7 +2128,7 @@ package body Sem_Ch6 is and then Contains_Refined_State (Prag) then Error_Msg_NE - ("body of subprogram & requires global refinement", + ("body of subprogram& requires global refinement", Body_Decl, Spec_Id); end if; end if; @@ -2116,7 +2151,7 @@ package body Sem_Ch6 is and then Contains_Refined_State (Prag) then Error_Msg_NE - ("body of subprogram & requires dependance refinement", + ("body of subprogram& requires dependance refinement", Body_Decl, Spec_Id); end if; end if; @@ -2171,6 +2206,10 @@ package body Sem_Ch6 is -- Analyze the aspect specifications of a subprogram body [stub]. It is -- assumed that N has aspects. + function Body_Has_Contract return Boolean; + -- Check whether unanalyzed body has an aspect or pragma that may + -- generate a SPARK contract. + procedure Check_Anonymous_Return; -- Ada 2005: if a function returns an access type that denotes a task, -- or a type that contains tasks, we must create a master entity for @@ -2343,6 +2382,68 @@ package body Sem_Ch6 is end if; end Analyze_Aspects_On_Body_Or_Stub; + ----------------------- + -- Body_Has_Contract -- + ----------------------- + + function Body_Has_Contract return Boolean is + Decls : constant List_Id := Declarations (N); + A_Spec : Node_Id; + A : Aspect_Id; + Decl : Node_Id; + P_Id : Pragma_Id; + + begin + -- Check for unanalyzed aspects in the body that will + -- generate a contract. + + if Present (Aspect_Specifications (N)) then + A_Spec := First (Aspect_Specifications (N)); + while Present (A_Spec) loop + A := Get_Aspect_Id (Chars (Identifier (A_Spec))); + + if A = Aspect_Contract_Cases or else + A = Aspect_Depends or else + A = Aspect_Global or else + A = Aspect_Pre or else + A = Aspect_Precondition or else + A = Aspect_Post or else + A = Aspect_Postcondition + then + return True; + end if; + + Next (A_Spec); + end loop; + end if; + + -- Check for pragmas that may generate a contract + + if Present (Decls) then + Decl := First (Decls); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma then + P_Id := Get_Pragma_Id (Pragma_Name (Decl)); + + if P_Id = Pragma_Contract_Cases or else + P_Id = Pragma_Depends or else + P_Id = Pragma_Global or else + P_Id = Pragma_Pre or else + P_Id = Pragma_Precondition or else + P_Id = Pragma_Post or else + P_Id = Pragma_Postcondition + then + return True; + end if; + end if; + + Next (Decl); + end loop; + end if; + + return False; + end Body_Has_Contract; + ---------------------------- -- Check_Anonymous_Return -- ---------------------------- @@ -2571,7 +2672,7 @@ package body Sem_Ch6 is and then not Nkind_In (Stat, N_Simple_Return_Statement, N_Extended_Return_Statement) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("last statement in function should be RETURN", Stat); end if; end; @@ -2589,7 +2690,7 @@ package body Sem_Ch6 is -- borrow the Check_Returns procedure here ??? if Return_Present (Id) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("procedure should not have RETURN", N); end if; end if; @@ -2851,7 +2952,7 @@ package body Sem_Ch6 is and then Operator_Matches_Spec (Spec_Id, Spec_Id) then Error_Msg_NE - ("subprogram & overrides predefined operator ", + ("subprogram& overrides predefined operator ", Body_Spec, Spec_Id); -- Overriding indicators aren't allowed for protected subprogram @@ -2862,18 +2963,16 @@ package body Sem_Ch6 is Error_Msg_Warn := Error_To_Warning; Error_Msg_N - ("< N, To => New_Decl); + + -- Mark the newly moved aspects as not analyzed, so that + -- their effect on New_Decl is properly analyzed. + + Aspect := First (Aspect_Specifications (New_Decl)); + while Present (Aspect) loop + Set_Analyzed (Aspect, False); + Next (Aspect); + end loop; + + Analyze (New_Decl); + + -- The analysis of the generated subprogram declaration + -- may have introduced pragmas that need to be analyzed. + + Prag := Next (New_Decl); + while Prag /= N loop + Analyze (Prag); + Next (Prag); + end loop; + + Spec_Id := Defining_Entity (New_Decl); + + -- As Body_Id originally comes from source, mark the new + -- Spec_Id as such, which is required so that calls to + -- this subprogram are registered in the local effects + -- stored in ALI files for GNATprove. + + Set_Comes_From_Source (Spec_Id, True); + + -- If aspect SPARK_Mode was specified on the body, it + -- needs to be repeated on the generated decl and the + -- body. Since the original aspect was moved to the + -- generated decl, copy it for the body. + + if Has_Aspect (Spec_Id, Aspect_SPARK_Mode) then + SPARK_Mode_Aspect := + New_Copy (Find_Aspect (Spec_Id, Aspect_SPARK_Mode)); + Set_Analyzed (SPARK_Mode_Aspect, False); + Aspects := New_List (SPARK_Mode_Aspect); + Set_Aspect_Specifications (N, Aspects); + end if; + + Set_Specification (N, Body_Spec); + Body_Id := Analyze_Subprogram_Specification (Body_Spec); + Set_Corresponding_Spec (N, Spec_Id); + end; + end if; end if; -- If this is a duplicate body, no point in analyzing it @@ -3345,29 +3550,99 @@ package body Sem_Ch6 is return; end if; - -- Handle frontend inlining. There is no need to prepare us for inlining - -- if we will not generate the code. + -- Handle frontend inlining - -- Old semantics + -- 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 + -- mode where we want to expand some calls in place, even with expansion + -- disabled, since the inlining eases formal verification. - if not Debug_Flag_Dot_K then - if Present (Spec_Id) - and then Expander_Active - and then - (Has_Pragma_Inline_Always (Spec_Id) - or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining)) - then - Build_Body_To_Inline (N, Spec_Id); + if not GNATprove_Mode + and then Expander_Active + and then Serious_Errors_Detected = 0 + and then Present (Spec_Id) + and then Has_Pragma_Inline (Spec_Id) + then + -- Legacy implementation (relying on frontend inlining) + + if not Back_End_Inlining then + if Has_Pragma_Inline_Always (Spec_Id) + or else (Has_Pragma_Inline (Spec_Id) and Front_End_Inlining) + then + Build_Body_To_Inline (N, Spec_Id); + end if; + + -- New implementation (relying on backend inlining). Enabled by + -- debug flag gnatd.z for testing + + else + if Has_Pragma_Inline_Always (Spec_Id) + or else Optimization_Level > 0 + then + -- Handle function returning an unconstrained type + + if Comes_From_Source (Body_Id) + and then Ekind (Spec_Id) = E_Function + and then Returns_Unconstrained_Type (Spec_Id) + then + Check_And_Split_Unconstrained_Function (N, Spec_Id, Body_Id); + + else + declare + Subp_Body : constant Node_Id := + Unit_Declaration_Node (Body_Id); + Subp_Decl : constant List_Id := Declarations (Subp_Body); + + begin + -- Do not pass inlining to the backend if the subprogram + -- has declarations or statements which cannot be inlined + -- by the backend. This check is done here to emit an + -- error instead of the generic warning message reported + -- by the GCC backend (ie. "function might not be + -- inlinable"). + + if Present (Subp_Decl) + and then Has_Excluded_Declaration (Spec_Id, Subp_Decl) + then + null; + + elsif Has_Excluded_Statement + (Spec_Id, + Statements + (Handled_Statement_Sequence (Subp_Body))) + then + null; + + -- If the backend inlining is available then at this + -- stage we only have to mark the subprogram as inlined. + -- The expander will take care of registering it in the + -- table of subprograms inlined by the backend a part of + -- processing calls to it (cf. Expand_Call) + + else + Set_Is_Inlined (Spec_Id); + end if; + end; + end if; + end if; end if; - -- New semantics + -- 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 + -- inlining. This inlining should occur after analysis of the body, so + -- that it is known whether the value of SPARK_Mode applicable to the + -- body, which can be defined by a pragma inside the body. - elsif Expander_Active - and then Serious_Errors_Detected = 0 + elsif GNATprove_Mode + and then Full_Analysis + and then not Inside_A_Generic and then Present (Spec_Id) - and then Has_Pragma_Inline (Spec_Id) + and then Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Declaration + and then Can_Be_Inlined_In_GNATprove_Mode (Spec_Id, Body_Id) + and then not Body_Has_Contract then - Check_And_Build_Body_To_Inline (N, Spec_Id, Body_Id); + Build_Body_To_Inline (N, Spec_Id); end if; -- Ada 2005 (AI-262): In library subprogram bodies, after the analysis @@ -3464,9 +3739,7 @@ package body Sem_Ch6 is Analyze_Declarations (Declarations (N)); - -- After declarations have been analyzed, the body has been set - -- its final value of SPARK_Mode. Check that SPARK_Mode for body - -- is consistent with SPARK_Mode for spec. + -- Verify that the SPARK_Mode of the body agrees with that of its spec if Present (Spec_Id) and then Present (SPARK_Pragma (Body_Id)) then if Present (SPARK_Pragma (Spec_Id)) then @@ -3478,7 +3751,7 @@ package body Sem_Ch6 is Error_Msg_N ("incorrect application of SPARK_Mode#", N); Error_Msg_Sloc := Sloc (SPARK_Pragma (Spec_Id)); Error_Msg_NE - ("\value Off was set for SPARK_Mode on&#", N, Spec_Id); + ("\value Off was set for SPARK_Mode on & #", N, Spec_Id); end if; elsif Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Body_Stub then @@ -3486,12 +3759,25 @@ package body Sem_Ch6 is else Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id)); - Error_Msg_N ("incorrect application of SPARK_Mode#", N); + Error_Msg_N ("incorrect application of SPARK_Mode #", N); Error_Msg_Sloc := Sloc (Spec_Id); - Error_Msg_NE ("\no value was set for SPARK_Mode on&#", N, Spec_Id); + Error_Msg_NE + ("\no value was set for SPARK_Mode on & #", N, Spec_Id); end if; end if; + -- 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; @@ -3853,7 +4139,7 @@ package body Sem_Ch6 is if Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) then - Check_SPARK_Restriction ("null procedure is not allowed", N); + Check_SPARK_05_Restriction ("null procedure is not allowed", N); if Is_Protected_Type (Current_Scope) then Error_Msg_N ("protected operation cannot be a null procedure", N); @@ -3968,1975 +4254,251 @@ package body Sem_Ch6 is Error_Msg_N ("interface procedure % must be abstract or null", N); else - Error_Msg_N ("interface function % must be abstract", N); - end if; - end if; - end; - end if; - - -- What is the following code for, it used to be - - -- ??? Set_Suppress_Elaboration_Checks - -- ??? (Designator, Elaboration_Checks_Suppressed (Designator)); - - -- The following seems equivalent, but a bit dubious - - if Elaboration_Checks_Suppressed (Designator) then - Set_Kill_Elaboration_Checks (Designator); - end if; - - if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then - Set_Categorization_From_Scope (Designator, Scop); - - else - -- For a compilation unit, check for library-unit pragmas - - Push_Scope (Designator); - Set_Categorization_From_Pragmas (N); - Validate_Categorization_Dependency (N, Designator); - Pop_Scope; - end if; - - -- For a compilation unit, set body required. This flag will only be - -- reset if a valid Import or Interface pragma is processed later on. - - if Nkind (Parent (N)) = N_Compilation_Unit then - Set_Body_Required (Parent (N), True); - - if Ada_Version >= Ada_2005 - and then Nkind (Specification (N)) = N_Procedure_Specification - and then Null_Present (Specification (N)) - then - Error_Msg_N - ("null procedure cannot be declared at library level", N); - end if; - end if; - - Generate_Reference_To_Formals (Designator); - Check_Eliminated (Designator); - - if Debug_Flag_C then - Outdent; - Write_Str ("<== subprogram spec "); - Write_Name (Chars (Designator)); - Write_Str (" from "); - Write_Location (Sloc (N)); - Write_Eol; - end if; - - if Is_Protected_Type (Current_Scope) then - - -- Indicate that this is a protected operation, because it may be - -- used in subsequent declarations within the protected type. - - Set_Convention (Designator, Convention_Protected); - end if; - - List_Inherited_Pre_Post_Aspects (Designator); - - if Has_Aspects (N) then - Analyze_Aspect_Specifications (N, Designator); - end if; - end Analyze_Subprogram_Declaration; - - -------------------------------------- - -- Analyze_Subprogram_Specification -- - -------------------------------------- - - -- Reminder: N here really is a subprogram specification (not a subprogram - -- declaration). This procedure is called to analyze the specification in - -- both subprogram bodies and subprogram declarations (specs). - - function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is - Designator : constant Entity_Id := Defining_Entity (N); - Formals : constant List_Id := Parameter_Specifications (N); - - -- Start of processing for Analyze_Subprogram_Specification - - begin - -- User-defined operator is not allowed in SPARK, except as a renaming - - if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol - and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration - then - Check_SPARK_Restriction ("user-defined operator is not allowed", N); - end if; - - -- Proceed with analysis. Do not emit a cross-reference entry if the - -- specification comes from an expression function, because it may be - -- the completion of a previous declaration. It is is not, the cross- - -- reference entry will be emitted for the new subprogram declaration. - - if Nkind (Parent (N)) /= N_Expression_Function then - Generate_Definition (Designator); - end if; - - Set_Contract (Designator, Make_Contract (Sloc (Designator))); - - if Nkind (N) = N_Function_Specification then - Set_Ekind (Designator, E_Function); - Set_Mechanism (Designator, Default_Mechanism); - else - Set_Ekind (Designator, E_Procedure); - Set_Etype (Designator, Standard_Void_Type); - end if; - - -- Introduce new scope for analysis of the formals and the return type - - Set_Scope (Designator, Current_Scope); - - if Present (Formals) then - Push_Scope (Designator); - Process_Formals (Formals, N); - - -- Check dimensions in N for formals with default expression - - Analyze_Dimension_Formals (N, Formals); - - -- Ada 2005 (AI-345): If this is an overriding operation of an - -- inherited interface operation, and the controlling type is - -- a synchronized type, replace the type with its corresponding - -- record, to match the proper signature of an overriding operation. - -- Same processing for an access parameter whose designated type is - -- derived from a synchronized interface. - - if Ada_Version >= Ada_2005 then - declare - Formal : Entity_Id; - Formal_Typ : Entity_Id; - Rec_Typ : Entity_Id; - Desig_Typ : Entity_Id; - - begin - Formal := First_Formal (Designator); - while Present (Formal) loop - Formal_Typ := Etype (Formal); - - if Is_Concurrent_Type (Formal_Typ) - and then Present (Corresponding_Record_Type (Formal_Typ)) - then - Rec_Typ := Corresponding_Record_Type (Formal_Typ); - - if Present (Interfaces (Rec_Typ)) then - Set_Etype (Formal, Rec_Typ); - end if; - - elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then - Desig_Typ := Designated_Type (Formal_Typ); - - if Is_Concurrent_Type (Desig_Typ) - and then Present (Corresponding_Record_Type (Desig_Typ)) - then - Rec_Typ := Corresponding_Record_Type (Desig_Typ); - - if Present (Interfaces (Rec_Typ)) then - Set_Directly_Designated_Type (Formal_Typ, Rec_Typ); - end if; - end if; - end if; - - Next_Formal (Formal); - end loop; - end; - end if; - - End_Scope; - - -- The subprogram scope is pushed and popped around the processing of - -- the return type for consistency with call above to Process_Formals - -- (which itself can call Analyze_Return_Type), and to ensure that any - -- itype created for the return type will be associated with the proper - -- scope. - - elsif Nkind (N) = N_Function_Specification then - Push_Scope (Designator); - Analyze_Return_Type (N); - End_Scope; - end if; - - -- Function case - - if Nkind (N) = N_Function_Specification then - - -- Deal with operator symbol case - - if Nkind (Designator) = N_Defining_Operator_Symbol then - Valid_Operator_Definition (Designator); - end if; - - May_Need_Actuals (Designator); - - -- Ada 2005 (AI-251): If the return type is abstract, verify that - -- the subprogram is abstract also. This does not apply to renaming - -- declarations, where abstractness is inherited, and to subprogram - -- bodies generated for stream operations, which become renamings as - -- bodies. - - -- In case of primitives associated with abstract interface types - -- the check is applied later (see Analyze_Subprogram_Declaration). - - if not Nkind_In (Original_Node (Parent (N)), - N_Subprogram_Renaming_Declaration, - N_Abstract_Subprogram_Declaration, - N_Formal_Abstract_Subprogram_Declaration) - then - if Is_Abstract_Type (Etype (Designator)) - and then not Is_Interface (Etype (Designator)) - then - Error_Msg_N - ("function that returns abstract type must be abstract", N); - - -- Ada 2012 (AI-0073): Extend this test to subprograms with an - -- access result whose designated type is abstract. - - elsif Nkind (Result_Definition (N)) = N_Access_Definition - and then - not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) - and then Is_Abstract_Type (Designated_Type (Etype (Designator))) - and then Ada_Version >= Ada_2012 - then - Error_Msg_N ("function whose access result designates " - & "abstract type must be abstract", N); - end if; - end if; - end if; - - return Designator; - end Analyze_Subprogram_Specification; - - -------------------------- - -- Build_Body_To_Inline -- - -------------------------- - - procedure Build_Body_To_Inline (N : Node_Id; Subp : Entity_Id) is - Decl : constant Node_Id := Unit_Declaration_Node (Subp); - Original_Body : Node_Id; - Body_To_Analyze : Node_Id; - Max_Size : constant := 10; - Stat_Count : Integer := 0; - - function Has_Excluded_Declaration (Decls : List_Id) return Boolean; - -- Check for declarations that make inlining not worthwhile - - function Has_Excluded_Statement (Stats : List_Id) return Boolean; - -- Check for statements that make inlining not worthwhile: any tasking - -- statement, nested at any level. Keep track of total number of - -- elementary statements, as a measure of acceptable size. - - function Has_Pending_Instantiation return Boolean; - -- If some enclosing body contains instantiations that appear before the - -- corresponding generic body, the enclosing body has a freeze node so - -- that it can be elaborated after the generic itself. This might - -- conflict with subsequent inlinings, so that it is unsafe to try to - -- inline in such a case. - - function Has_Single_Return return Boolean; - -- In general we cannot inline functions that return unconstrained type. - -- However, we can handle such functions if all return statements return - -- a local variable that is the only declaration in the body of the - -- function. In that case the call can be replaced by that local - -- variable as is done for other inlined calls. - - procedure Remove_Pragmas; - -- A pragma Unreferenced or pragma Unmodified that mentions a formal - -- parameter has no meaning when the body is inlined and the formals - -- are rewritten. Remove it from body to inline. The analysis of the - -- non-inlined body will handle the pragma properly. - - function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; - -- If the body of the subprogram includes a call that returns an - -- unconstrained type, the secondary stack is involved, and it - -- is not worth inlining. - - ------------------------------ - -- Has_Excluded_Declaration -- - ------------------------------ - - function Has_Excluded_Declaration (Decls : List_Id) return Boolean is - D : Node_Id; - - function Is_Unchecked_Conversion (D : Node_Id) return Boolean; - -- Nested subprograms make a given body ineligible for inlining, but - -- we make an exception for instantiations of unchecked conversion. - -- The body has not been analyzed yet, so check the name, and verify - -- that the visible entity with that name is the predefined unit. - - ----------------------------- - -- Is_Unchecked_Conversion -- - ----------------------------- - - function Is_Unchecked_Conversion (D : Node_Id) return Boolean is - Id : constant Node_Id := Name (D); - Conv : Entity_Id; - - begin - if Nkind (Id) = N_Identifier - and then Chars (Id) = Name_Unchecked_Conversion - then - Conv := Current_Entity (Id); - - elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) - and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion - then - Conv := Current_Entity (Selector_Name (Id)); - else - return False; - end if; - - return Present (Conv) - and then Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Conv))) - and then Is_Intrinsic_Subprogram (Conv); - end Is_Unchecked_Conversion; - - -- Start of processing for Has_Excluded_Declaration - - begin - D := First (Decls); - while Present (D) loop - if (Nkind (D) = N_Function_Instantiation - and then not Is_Unchecked_Conversion (D)) - or else Nkind_In (D, N_Protected_Type_Declaration, - N_Package_Declaration, - N_Package_Instantiation, - N_Subprogram_Body, - N_Procedure_Instantiation, - N_Task_Type_Declaration) - then - Cannot_Inline - ("cannot inline & (non-allowed declaration)?", D, Subp); - return True; - end if; - - Next (D); - end loop; - - return False; - end Has_Excluded_Declaration; - - ---------------------------- - -- Has_Excluded_Statement -- - ---------------------------- - - function Has_Excluded_Statement (Stats : List_Id) return Boolean is - S : Node_Id; - E : Node_Id; - - begin - S := First (Stats); - while Present (S) loop - Stat_Count := Stat_Count + 1; - - if Nkind_In (S, N_Abort_Statement, - N_Asynchronous_Select, - N_Conditional_Entry_Call, - N_Delay_Relative_Statement, - N_Delay_Until_Statement, - N_Selective_Accept, - N_Timed_Entry_Call) - then - Cannot_Inline - ("cannot inline & (non-allowed statement)?", S, Subp); - return True; - - elsif Nkind (S) = N_Block_Statement then - if Present (Declarations (S)) - and then Has_Excluded_Declaration (Declarations (S)) - then - return True; - - elsif Present (Handled_Statement_Sequence (S)) - and then - (Present - (Exception_Handlers (Handled_Statement_Sequence (S))) - or else - Has_Excluded_Statement - (Statements (Handled_Statement_Sequence (S)))) - then - return True; - end if; - - elsif Nkind (S) = N_Case_Statement then - E := First (Alternatives (S)); - while Present (E) loop - if Has_Excluded_Statement (Statements (E)) then - return True; - end if; - - Next (E); - end loop; - - elsif Nkind (S) = N_If_Statement then - if Has_Excluded_Statement (Then_Statements (S)) then - return True; - end if; - - if Present (Elsif_Parts (S)) then - E := First (Elsif_Parts (S)); - while Present (E) loop - if Has_Excluded_Statement (Then_Statements (E)) then - return True; - end if; - - Next (E); - end loop; - end if; - - if Present (Else_Statements (S)) - and then Has_Excluded_Statement (Else_Statements (S)) - then - return True; - end if; - - elsif Nkind (S) = N_Loop_Statement - and then Has_Excluded_Statement (Statements (S)) - then - return True; - - elsif Nkind (S) = N_Extended_Return_Statement then - if Has_Excluded_Statement - (Statements (Handled_Statement_Sequence (S))) - or else Present - (Exception_Handlers (Handled_Statement_Sequence (S))) - then - return True; - end if; - end if; - - Next (S); - end loop; - - return False; - end Has_Excluded_Statement; - - ------------------------------- - -- Has_Pending_Instantiation -- - ------------------------------- - - function Has_Pending_Instantiation return Boolean is - S : Entity_Id; - - begin - S := Current_Scope; - while Present (S) loop - if Is_Compilation_Unit (S) - or else Is_Child_Unit (S) - then - return False; - - elsif Ekind (S) = E_Package - and then Has_Forward_Instantiation (S) - then - return True; - end if; - - S := Scope (S); - end loop; - - return False; - end Has_Pending_Instantiation; - - ------------------------ - -- Has_Single_Return -- - ------------------------ - - function Has_Single_Return return Boolean is - Return_Statement : Node_Id := Empty; - - function Check_Return (N : Node_Id) return Traverse_Result; - - ------------------ - -- Check_Return -- - ------------------ - - function Check_Return (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Simple_Return_Statement then - if Present (Expression (N)) - and then Is_Entity_Name (Expression (N)) - then - if No (Return_Statement) then - Return_Statement := N; - return OK; - - elsif Chars (Expression (N)) = - Chars (Expression (Return_Statement)) - then - return OK; - - else - return Abandon; - end if; - - -- A return statement within an extended return is a noop - -- after inlining. - - elsif No (Expression (N)) - and then Nkind (Parent (Parent (N))) = - N_Extended_Return_Statement - then - return OK; - - else - -- Expression has wrong form - - return Abandon; - end if; - - -- We can only inline a build-in-place function if - -- it has a single extended return. - - elsif Nkind (N) = N_Extended_Return_Statement then - if No (Return_Statement) then - Return_Statement := N; - return OK; - - else - return Abandon; - end if; - - else - return OK; - end if; - end Check_Return; - - function Check_All_Returns is new Traverse_Func (Check_Return); - - -- Start of processing for Has_Single_Return - - begin - if Check_All_Returns (N) /= OK then - return False; - - elsif Nkind (Return_Statement) = N_Extended_Return_Statement then - return True; - - else - return Present (Declarations (N)) - and then Present (First (Declarations (N))) - and then Chars (Expression (Return_Statement)) = - Chars (Defining_Identifier (First (Declarations (N)))); - end if; - end Has_Single_Return; - - -------------------- - -- Remove_Pragmas -- - -------------------- - - procedure Remove_Pragmas is - Decl : Node_Id; - Nxt : Node_Id; - - begin - Decl := First (Declarations (Body_To_Analyze)); - while Present (Decl) loop - Nxt := Next (Decl); - - if Nkind (Decl) = N_Pragma - and then Nam_In (Pragma_Name (Decl), Name_Unreferenced, - Name_Unmodified) - then - Remove (Decl); - end if; - - Decl := Nxt; - end loop; - end Remove_Pragmas; - - -------------------------- - -- Uses_Secondary_Stack -- - -------------------------- - - function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is - function Check_Call (N : Node_Id) return Traverse_Result; - -- Look for function calls that return an unconstrained type - - ---------------- - -- Check_Call -- - ---------------- - - function Check_Call (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Function_Call - and then Is_Entity_Name (Name (N)) - and then Is_Composite_Type (Etype (Entity (Name (N)))) - and then not Is_Constrained (Etype (Entity (Name (N)))) - then - Cannot_Inline - ("cannot inline & (call returns unconstrained type)?", - N, Subp); - return Abandon; - else - return OK; - end if; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - begin - return Check_Calls (Bod) = Abandon; - end Uses_Secondary_Stack; - - -- Start of processing for Build_Body_To_Inline - - begin - -- Return immediately if done already - - if Nkind (Decl) = N_Subprogram_Declaration - and then Present (Body_To_Inline (Decl)) - then - return; - - -- Functions that return unconstrained composite types require - -- secondary stack handling, and cannot currently be inlined, unless - -- all return statements return a local variable that is the first - -- local declaration in the body. - - elsif Ekind (Subp) = E_Function - and then not Is_Scalar_Type (Etype (Subp)) - and then not Is_Access_Type (Etype (Subp)) - and then not Is_Constrained (Etype (Subp)) - then - if not Has_Single_Return then - Cannot_Inline - ("cannot inline & (unconstrained return type)?", N, Subp); - return; - end if; - - -- Ditto for functions that return controlled types, where controlled - -- actions interfere in complex ways with inlining. - - elsif Ekind (Subp) = E_Function - and then Needs_Finalization (Etype (Subp)) - then - Cannot_Inline - ("cannot inline & (controlled return type)?", N, Subp); - return; - end if; - - if Present (Declarations (N)) - and then Has_Excluded_Declaration (Declarations (N)) - then - return; - end if; - - if Present (Handled_Statement_Sequence (N)) then - if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then - Cannot_Inline - ("cannot inline& (exception handler)?", - First (Exception_Handlers (Handled_Statement_Sequence (N))), - Subp); - return; - elsif - Has_Excluded_Statement - (Statements (Handled_Statement_Sequence (N))) - then - return; - end if; - end if; - - -- We do not inline a subprogram that is too large, unless it is - -- marked Inline_Always. This pragma does not suppress the other - -- checks on inlining (forbidden declarations, handlers, etc). - - if Stat_Count > Max_Size - and then not Has_Pragma_Inline_Always (Subp) - then - Cannot_Inline ("cannot inline& (body too large)?", N, Subp); - return; - end if; - - if Has_Pending_Instantiation then - Cannot_Inline - ("cannot inline& (forward instance within enclosing body)?", - N, Subp); - return; - end if; - - -- Within an instance, the body to inline must be treated as a nested - -- generic, so that the proper global references are preserved. - - -- Note that we do not do this at the library level, because it is not - -- needed, and furthermore this causes trouble if front end inlining - -- is activated (-gnatN). - - if In_Instance and then Scope (Current_Scope) /= Standard_Standard then - Save_Env (Scope (Current_Scope), Scope (Current_Scope)); - Original_Body := Copy_Generic_Node (N, Empty, True); - else - Original_Body := Copy_Separate_Tree (N); - end if; - - -- We need to capture references to the formals in order to substitute - -- the actuals at the point of inlining, i.e. instantiation. To treat - -- the formals as globals to the body to inline, we nest it within - -- a dummy parameterless subprogram, declared within the real one. - -- To avoid generating an internal name (which is never public, and - -- which affects serial numbers of other generated names), we use - -- an internal symbol that cannot conflict with user declarations. - - Set_Parameter_Specifications (Specification (Original_Body), No_List); - Set_Defining_Unit_Name - (Specification (Original_Body), - Make_Defining_Identifier (Sloc (N), Name_uParent)); - Set_Corresponding_Spec (Original_Body, Empty); - - Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); - - -- Set return type of function, which is also global and does not need - -- to be resolved. - - if Ekind (Subp) = E_Function then - Set_Result_Definition (Specification (Body_To_Analyze), - New_Occurrence_Of (Etype (Subp), Sloc (N))); - end if; - - if No (Declarations (N)) then - Set_Declarations (N, New_List (Body_To_Analyze)); - else - Append (Body_To_Analyze, Declarations (N)); - end if; - - Expander_Mode_Save_And_Set (False); - Remove_Pragmas; - - Analyze (Body_To_Analyze); - Push_Scope (Defining_Entity (Body_To_Analyze)); - Save_Global_References (Original_Body); - End_Scope; - Remove (Body_To_Analyze); - - Expander_Mode_Restore; - - -- Restore environment if previously saved - - if In_Instance and then Scope (Current_Scope) /= Standard_Standard then - Restore_Env; - end if; - - -- If secondary stk used there is no point in inlining. We have - -- already issued the warning in this case, so nothing to do. - - if Uses_Secondary_Stack (Body_To_Analyze) then - return; - end if; - - Set_Body_To_Inline (Decl, Original_Body); - Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp)); - Set_Is_Inlined (Subp); - end Build_Body_To_Inline; - - ------------------- - -- Cannot_Inline -- - ------------------- - - procedure Cannot_Inline - (Msg : String; - N : Node_Id; - Subp : Entity_Id; - Is_Serious : Boolean := False) - is - begin - pragma Assert (Msg (Msg'Last) = '?'); - - -- Old semantics - - if not Debug_Flag_Dot_K 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; - - 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; - - return; - - -- New semantics - - 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); - - elsif Optimization_Level = 0 then - - -- 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 pragma Assert (Front_End_Inlining); - Set_Is_Inlined (Subp, False); - - -- When inlining cannot take place we must issue an error. - -- For backward compatibility we still report a warning. - - if Ineffective_Inline_Warnings then - Error_Msg_NE (Msg & "p?", N, Subp); - end if; - end if; - - -- Compiling with optimizations enabled it is too early to report - -- problems since the backend may still perform inlining. In order - -- to report unhandled inlinings the program must be compiled with - -- -Winline and the error is reported by the backend. - - else - null; - end if; - end Cannot_Inline; - - ------------------------------------ - -- Check_And_Build_Body_To_Inline -- - ------------------------------------ - - procedure Check_And_Build_Body_To_Inline - (N : Node_Id; - Spec_Id : Entity_Id; - Body_Id : Entity_Id) - is - procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id); - -- Use generic machinery to build an unexpanded body for the subprogram. - -- This body is subsequently used for inline expansions at call sites. - - function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean; - -- Return true if we generate code for the function body N, the function - -- body N has no local declarations and its unique statement is a single - -- extended return statement with a handled statements sequence. - - function Check_Body_To_Inline - (N : Node_Id; - Subp : Entity_Id) return Boolean; - -- N is the N_Subprogram_Body of Subp. Return true if Subp can be - -- inlined by the frontend. These are the rules: - -- * At -O0 use fe inlining when inline_always is specified except if - -- the function returns a controlled type. - -- * At other optimization levels use the fe inlining for both inline - -- and inline_always in the following cases: - -- - function returning a known at compile time constant - -- - function returning a call to an intrinsic function - -- - function returning an unconstrained type (see Can_Split - -- Unconstrained_Function). - -- - function returning a call to a frontend-inlined function - -- Use the back-end mechanism otherwise - -- - -- In addition, in the following cases the function cannot be inlined by - -- the frontend: - -- - functions that uses the secondary stack - -- - functions that have declarations of: - -- - Concurrent types - -- - Packages - -- - Instantiations - -- - Subprograms - -- - functions that have some of the following statements: - -- - abort - -- - asynchronous-select - -- - conditional-entry-call - -- - delay-relative - -- - delay-until - -- - selective-accept - -- - timed-entry-call - -- - functions that have exception handlers - -- - functions that have some enclosing body containing instantiations - -- that appear before the corresponding generic body. - - procedure Generate_Body_To_Inline - (N : Node_Id; - Body_To_Inline : out Node_Id); - -- Generate a parameterless duplicate of subprogram body N. Occurrences - -- of pragmas referencing the formals are removed since they have no - -- meaning when the body is inlined and the formals are rewritten (the - -- analysis of the non-inlined body will handle these pragmas properly). - -- A new internal name is associated with Body_To_Inline. - - procedure Split_Unconstrained_Function - (N : Node_Id; - Spec_Id : Entity_Id); - -- N is an inlined function body that returns an unconstrained type and - -- has a single extended return statement. Split N in two subprograms: - -- a procedure P' and a function F'. The formals of P' duplicate the - -- formals of N plus an extra formal which is used return a value; - -- its body is composed by the declarations and list of statements - -- of the extended return statement of N. - - -------------------------- - -- Build_Body_To_Inline -- - -------------------------- - - procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is - Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); - Original_Body : Node_Id; - Body_To_Analyze : Node_Id; - - begin - pragma Assert (Current_Scope = Spec_Id); - - -- Within an instance, the body to inline must be treated as a nested - -- generic, so that the proper global references are preserved. We - -- do not do this at the library level, because it is not needed, and - -- furthermore this causes trouble if front end inlining is activated - -- (-gnatN). - - if In_Instance - and then Scope (Current_Scope) /= Standard_Standard - then - Save_Env (Scope (Current_Scope), Scope (Current_Scope)); - end if; - - -- We need to capture references to the formals in order - -- to substitute the actuals at the point of inlining, i.e. - -- instantiation. To treat the formals as globals to the body to - -- inline, we nest it within a dummy parameterless subprogram, - -- declared within the real one. - - Generate_Body_To_Inline (N, Original_Body); - Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False); - - -- Set return type of function, which is also global and does not - -- need to be resolved. - - if Ekind (Spec_Id) = E_Function then - Set_Result_Definition (Specification (Body_To_Analyze), - New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); - end if; - - if No (Declarations (N)) then - Set_Declarations (N, New_List (Body_To_Analyze)); - else - Append_To (Declarations (N), Body_To_Analyze); - end if; - - Preanalyze (Body_To_Analyze); - - Push_Scope (Defining_Entity (Body_To_Analyze)); - Save_Global_References (Original_Body); - End_Scope; - Remove (Body_To_Analyze); - - -- Restore environment if previously saved - - if In_Instance - and then Scope (Current_Scope) /= Standard_Standard - then - Restore_Env; - end if; - - pragma Assert (No (Body_To_Inline (Decl))); - Set_Body_To_Inline (Decl, Original_Body); - Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); - end Build_Body_To_Inline; - - -------------------------- - -- Check_Body_To_Inline -- - -------------------------- - - function Check_Body_To_Inline - (N : Node_Id; - Subp : Entity_Id) return Boolean - is - Max_Size : constant := 10; - Stat_Count : Integer := 0; - - function Has_Excluded_Declaration (Decls : List_Id) return Boolean; - -- Check for declarations that make inlining not worthwhile - - function Has_Excluded_Statement (Stats : List_Id) return Boolean; - -- Check for statements that make inlining not worthwhile: any - -- tasking statement, nested at any level. Keep track of total - -- number of elementary statements, as a measure of acceptable size. - - function Has_Pending_Instantiation return Boolean; - -- Return True if some enclosing body contains instantiations that - -- appear before the corresponding generic body. - - function Returns_Compile_Time_Constant (N : Node_Id) return Boolean; - -- Return True if all the return statements of the function body N - -- are simple return statements and return a compile time constant - - function Returns_Intrinsic_Function_Call (N : Node_Id) return Boolean; - -- Return True if all the return statements of the function body N - -- are simple return statements and return an intrinsic function call - - function Uses_Secondary_Stack (N : Node_Id) return Boolean; - -- If the body of the subprogram includes a call that returns an - -- unconstrained type, the secondary stack is involved, and it - -- is not worth inlining. - - ------------------------------ - -- Has_Excluded_Declaration -- - ------------------------------ - - function Has_Excluded_Declaration (Decls : List_Id) return Boolean is - D : Node_Id; - - function Is_Unchecked_Conversion (D : Node_Id) return Boolean; - -- Nested subprograms make a given body ineligible for inlining, - -- but we make an exception for instantiations of unchecked - -- conversion. The body has not been analyzed yet, so check the - -- name, and verify that the visible entity with that name is the - -- predefined unit. - - ----------------------------- - -- Is_Unchecked_Conversion -- - ----------------------------- - - function Is_Unchecked_Conversion (D : Node_Id) return Boolean is - Id : constant Node_Id := Name (D); - Conv : Entity_Id; - - begin - if Nkind (Id) = N_Identifier - and then Chars (Id) = Name_Unchecked_Conversion - then - Conv := Current_Entity (Id); - - elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) - and then - Chars (Selector_Name (Id)) = Name_Unchecked_Conversion - then - Conv := Current_Entity (Selector_Name (Id)); - else - return False; - end if; - - return Present (Conv) - and then Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Conv))) - and then Is_Intrinsic_Subprogram (Conv); - end Is_Unchecked_Conversion; - - -- Start of processing for Has_Excluded_Declaration - - begin - D := First (Decls); - while Present (D) loop - if (Nkind (D) = N_Function_Instantiation - and then not Is_Unchecked_Conversion (D)) - or else Nkind_In (D, N_Protected_Type_Declaration, - N_Package_Declaration, - N_Package_Instantiation, - N_Subprogram_Body, - N_Procedure_Instantiation, - N_Task_Type_Declaration) - then - Cannot_Inline - ("cannot inline & (non-allowed declaration)?", D, Subp); - - return True; - end if; - - Next (D); - end loop; - - return False; - end Has_Excluded_Declaration; - - ---------------------------- - -- Has_Excluded_Statement -- - ---------------------------- - - function Has_Excluded_Statement (Stats : List_Id) return Boolean is - S : Node_Id; - E : Node_Id; - - begin - S := First (Stats); - while Present (S) loop - Stat_Count := Stat_Count + 1; - - if Nkind_In (S, N_Abort_Statement, - N_Asynchronous_Select, - N_Conditional_Entry_Call, - N_Delay_Relative_Statement, - N_Delay_Until_Statement, - N_Selective_Accept, - N_Timed_Entry_Call) - then - Cannot_Inline - ("cannot inline & (non-allowed statement)?", S, Subp); - return True; - - elsif Nkind (S) = N_Block_Statement then - if Present (Declarations (S)) - and then Has_Excluded_Declaration (Declarations (S)) - then - return True; - - elsif Present (Handled_Statement_Sequence (S)) then - if Present - (Exception_Handlers (Handled_Statement_Sequence (S))) - then - Cannot_Inline - ("cannot inline& (exception handler)?", - First (Exception_Handlers - (Handled_Statement_Sequence (S))), - Subp); - return True; - - elsif Has_Excluded_Statement - (Statements (Handled_Statement_Sequence (S))) - then - return True; - end if; - end if; - - elsif Nkind (S) = N_Case_Statement then - E := First (Alternatives (S)); - while Present (E) loop - if Has_Excluded_Statement (Statements (E)) then - return True; - end if; - - Next (E); - end loop; - - elsif Nkind (S) = N_If_Statement then - if Has_Excluded_Statement (Then_Statements (S)) then - return True; - end if; - - if Present (Elsif_Parts (S)) then - E := First (Elsif_Parts (S)); - while Present (E) loop - if Has_Excluded_Statement (Then_Statements (E)) then - return True; - end if; - Next (E); - end loop; - end if; - - if Present (Else_Statements (S)) - and then Has_Excluded_Statement (Else_Statements (S)) - then - return True; - end if; - - elsif Nkind (S) = N_Loop_Statement - and then Has_Excluded_Statement (Statements (S)) - then - return True; - - elsif Nkind (S) = N_Extended_Return_Statement then - if Present (Handled_Statement_Sequence (S)) - and then - Has_Excluded_Statement - (Statements (Handled_Statement_Sequence (S))) - then - return True; - - elsif Present (Handled_Statement_Sequence (S)) - and then - Present (Exception_Handlers - (Handled_Statement_Sequence (S))) - then - Cannot_Inline - ("cannot inline& (exception handler)?", - First (Exception_Handlers - (Handled_Statement_Sequence (S))), - Subp); - return True; - end if; - end if; - - Next (S); - end loop; - - return False; - end Has_Excluded_Statement; - - ------------------------------- - -- Has_Pending_Instantiation -- - ------------------------------- - - function Has_Pending_Instantiation return Boolean is - S : Entity_Id; - - begin - S := Current_Scope; - while Present (S) loop - if Is_Compilation_Unit (S) - or else Is_Child_Unit (S) - then - return False; - - elsif Ekind (S) = E_Package - and then Has_Forward_Instantiation (S) - then - return True; - end if; - - S := Scope (S); - end loop; - - return False; - end Has_Pending_Instantiation; - - ------------------------------------ - -- Returns_Compile_Time_Constant -- - ------------------------------------ - - function Returns_Compile_Time_Constant (N : Node_Id) return Boolean is - - function Check_Return (N : Node_Id) return Traverse_Result; - - ------------------ - -- Check_Return -- - ------------------ - - function Check_Return (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Extended_Return_Statement then - return Abandon; - - elsif Nkind (N) = N_Simple_Return_Statement then - if Present (Expression (N)) then - declare - Orig_Expr : constant Node_Id := - Original_Node (Expression (N)); - - begin - if Nkind_In (Orig_Expr, N_Integer_Literal, - N_Real_Literal, - N_Character_Literal) - then - return OK; - - elsif Is_Entity_Name (Orig_Expr) - and then Ekind (Entity (Orig_Expr)) = E_Constant - and then Is_Static_Expression (Orig_Expr) - then - return OK; - else - return Abandon; - end if; - end; - - -- Expression has wrong form - - else - return Abandon; - end if; - - -- Continue analyzing statements - - else - return OK; - end if; - end Check_Return; - - function Check_All_Returns is new Traverse_Func (Check_Return); - - -- Start of processing for Returns_Compile_Time_Constant - - begin - return Check_All_Returns (N) = OK; - end Returns_Compile_Time_Constant; - - -------------------------------------- - -- Returns_Intrinsic_Function_Call -- - -------------------------------------- - - function Returns_Intrinsic_Function_Call - (N : Node_Id) return Boolean - is - function Check_Return (N : Node_Id) return Traverse_Result; - - ------------------ - -- Check_Return -- - ------------------ - - function Check_Return (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Extended_Return_Statement then - return Abandon; - - elsif Nkind (N) = N_Simple_Return_Statement then - if Present (Expression (N)) then - declare - Orig_Expr : constant Node_Id := - Original_Node (Expression (N)); - - begin - if Nkind (Orig_Expr) in N_Op - and then Is_Intrinsic_Subprogram (Entity (Orig_Expr)) - then - return OK; - - elsif Nkind (Orig_Expr) in N_Has_Entity - and then Present (Entity (Orig_Expr)) - and then Ekind (Entity (Orig_Expr)) = E_Function - and then Is_Inlined (Entity (Orig_Expr)) - then - return OK; - - elsif Nkind (Orig_Expr) in N_Has_Entity - and then Present (Entity (Orig_Expr)) - and then Is_Intrinsic_Subprogram (Entity (Orig_Expr)) - then - return OK; - - else - return Abandon; - end if; - end; - - -- Expression has wrong form - - else - return Abandon; - end if; - - -- Continue analyzing statements - - else - return OK; - end if; - end Check_Return; - - function Check_All_Returns is new Traverse_Func (Check_Return); - - -- Start of processing for Returns_Intrinsic_Function_Call - - begin - return Check_All_Returns (N) = OK; - end Returns_Intrinsic_Function_Call; - - -------------------------- - -- Uses_Secondary_Stack -- - -------------------------- - - function Uses_Secondary_Stack (N : Node_Id) return Boolean is - - function Check_Call (N : Node_Id) return Traverse_Result; - -- Look for function calls that return an unconstrained type - - ---------------- - -- Check_Call -- - ---------------- - - function Check_Call (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Function_Call - and then Is_Entity_Name (Name (N)) - and then Is_Composite_Type (Etype (Entity (Name (N)))) - and then not Is_Constrained (Etype (Entity (Name (N)))) - then - Cannot_Inline - ("cannot inline & (call returns unconstrained type)?", - N, Subp); - - return Abandon; - else - return OK; - end if; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - -- Start of processing for Uses_Secondary_Stack - - begin - return Check_Calls (N) = Abandon; - end Uses_Secondary_Stack; - - -- Local variables - - Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); - May_Inline : constant Boolean := - Has_Pragma_Inline_Always (Spec_Id) - or else (Has_Pragma_Inline (Spec_Id) - and then ((Optimization_Level > 0 - and then Ekind (Spec_Id) - = E_Function) - or else Front_End_Inlining)); - Body_To_Analyze : Node_Id; - - -- Start of processing for Check_Body_To_Inline - - begin - -- No action needed in stubs since the attribute Body_To_Inline - -- is not available - - if Nkind (Decl) = N_Subprogram_Body_Stub then - return False; - - -- Cannot build the body to inline if the attribute is already set. - -- This attribute may have been set if this is a subprogram renaming - -- declarations (see Freeze.Build_Renamed_Body). - - elsif Present (Body_To_Inline (Decl)) then - return False; - - -- No action needed if the subprogram does not fulfill the minimum - -- conditions to be inlined by the frontend - - elsif not May_Inline then - return False; - end if; - - -- Check excluded declarations - - if Present (Declarations (N)) - and then Has_Excluded_Declaration (Declarations (N)) - then - return False; - end if; - - -- Check excluded statements - - if Present (Handled_Statement_Sequence (N)) then - if Present - (Exception_Handlers (Handled_Statement_Sequence (N))) - then - Cannot_Inline - ("cannot inline& (exception handler)?", - First - (Exception_Handlers (Handled_Statement_Sequence (N))), - Subp); - - return False; - - elsif Has_Excluded_Statement - (Statements (Handled_Statement_Sequence (N))) - then - return False; - end if; - end if; - - -- For backward compatibility, compiling under -gnatN we do not - -- inline a subprogram that is too large, unless it is marked - -- Inline_Always. This pragma does not suppress the other checks - -- on inlining (forbidden declarations, handlers, etc). - - if Front_End_Inlining - and then not Has_Pragma_Inline_Always (Subp) - and then Stat_Count > Max_Size - then - Cannot_Inline ("cannot inline& (body too large)?", N, Subp); - return False; - end if; - - -- If some enclosing body contains instantiations that appear before - -- the corresponding generic body, the enclosing body has a freeze - -- node so that it can be elaborated after the generic itself. This - -- might conflict with subsequent inlinings, so that it is unsafe to - -- try to inline in such a case. - - if Has_Pending_Instantiation then - Cannot_Inline - ("cannot inline& (forward instance within enclosing body)?", - N, Subp); - - return False; - end if; - - -- Generate and preanalyze the body to inline (needed to perform - -- the rest of the checks) - - Generate_Body_To_Inline (N, Body_To_Analyze); - - if Ekind (Subp) = E_Function then - Set_Result_Definition (Specification (Body_To_Analyze), - New_Occurrence_Of (Etype (Subp), Sloc (N))); - end if; - - -- Nest the body to analyze within the real one - - if No (Declarations (N)) then - Set_Declarations (N, New_List (Body_To_Analyze)); - else - Append_To (Declarations (N), Body_To_Analyze); - end if; - - Preanalyze (Body_To_Analyze); - Remove (Body_To_Analyze); - - -- Keep separate checks needed when compiling without optimizations - - if Optimization_Level = 0 - - -- AAMP and VM targets have no support for inlining in the backend - -- and hence we use frontend inlining at all optimization levels. - - or else AAMP_On_Target - or else VM_Target /= No_VM - then - -- Cannot inline functions whose body has a call that returns an - -- unconstrained type since the secondary stack is involved, and - -- it is not worth inlining. - - if Uses_Secondary_Stack (Body_To_Analyze) then - return False; - - -- Cannot inline functions that return controlled types since - -- controlled actions interfere in complex ways with inlining. - - elsif Ekind (Subp) = E_Function - and then Needs_Finalization (Etype (Subp)) - then - Cannot_Inline - ("cannot inline & (controlled return type)?", N, Subp); - return False; - - elsif Returns_Unconstrained_Type (Subp) then - Cannot_Inline - ("cannot inline & (unconstrained return type)?", N, Subp); - return False; - end if; - - -- Compiling with optimizations enabled - - else - -- Procedures are never frontend inlined in this case - - if Ekind (Subp) /= E_Function then - return False; - - -- Functions returning unconstrained types are tested - -- separately (see Can_Split_Unconstrained_Function). - - elsif Returns_Unconstrained_Type (Subp) then - null; - - -- Check supported cases - - elsif not Returns_Compile_Time_Constant (Body_To_Analyze) - and then Convention (Subp) /= Convention_Intrinsic - and then not Returns_Intrinsic_Function_Call (Body_To_Analyze) - then - return False; - end if; - end if; - - return True; - end Check_Body_To_Inline; - - -------------------------------------- - -- Can_Split_Unconstrained_Function -- - -------------------------------------- - - function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean - is - Ret_Node : constant Node_Id := - First (Statements (Handled_Statement_Sequence (N))); - D : Node_Id; - - begin - -- No user defined declarations allowed in the function except inside - -- the unique return statement; implicit labels are the only allowed - -- declarations. - - if not Is_Empty_List (Declarations (N)) then - D := First (Declarations (N)); - while Present (D) loop - if Nkind (D) /= N_Implicit_Label_Declaration then - return False; - end if; - - Next (D); - end loop; - end if; - - -- We only split the inlined function when we are generating the code - -- of its body; otherwise we leave duplicated split subprograms in - -- the tree which (if referenced) generate wrong references at link - -- time. - - return In_Extended_Main_Code_Unit (N) - and then Present (Ret_Node) - and then Nkind (Ret_Node) = N_Extended_Return_Statement - and then No (Next (Ret_Node)) - and then Present (Handled_Statement_Sequence (Ret_Node)); - end Can_Split_Unconstrained_Function; - - ----------------------------- - -- Generate_Body_To_Inline -- - ----------------------------- + Error_Msg_N + ("interface function % must be abstract", N); + end if; + end if; + end; + end if; - procedure Generate_Body_To_Inline - (N : Node_Id; - Body_To_Inline : out Node_Id) - is - procedure Remove_Pragmas (N : Node_Id); - -- Remove occurrences of pragmas that may reference the formals of - -- N. The analysis of the non-inlined body will handle these pragmas - -- properly. + -- What is the following code for, it used to be - -------------------- - -- Remove_Pragmas -- - -------------------- + -- ??? Set_Suppress_Elaboration_Checks + -- ??? (Designator, Elaboration_Checks_Suppressed (Designator)); - procedure Remove_Pragmas (N : Node_Id) is - Decl : Node_Id; - Nxt : Node_Id; + -- The following seems equivalent, but a bit dubious - begin - Decl := First (Declarations (N)); - while Present (Decl) loop - Nxt := Next (Decl); + if Elaboration_Checks_Suppressed (Designator) then + Set_Kill_Elaboration_Checks (Designator); + end if; - if Nkind (Decl) = N_Pragma - and then Nam_In (Pragma_Name (Decl), Name_Unreferenced, - Name_Unmodified) - then - Remove (Decl); - end if; + if Scop /= Standard_Standard and then not Is_Child_Unit (Designator) then + Set_Categorization_From_Scope (Designator, Scop); - Decl := Nxt; - end loop; - end Remove_Pragmas; + else + -- For a compilation unit, check for library-unit pragmas - -- Start of processing for Generate_Body_To_Inline + Push_Scope (Designator); + Set_Categorization_From_Pragmas (N); + Validate_Categorization_Dependency (N, Designator); + Pop_Scope; + end if; - begin - -- Within an instance, the body to inline must be treated as a nested - -- generic, so that the proper global references are preserved. + -- For a compilation unit, set body required. This flag will only be + -- reset if a valid Import or Interface pragma is processed later on. - -- Note that we do not do this at the library level, because it - -- is not needed, and furthermore this causes trouble if front - -- end inlining is activated (-gnatN). + if Nkind (Parent (N)) = N_Compilation_Unit then + Set_Body_Required (Parent (N), True); - if In_Instance - and then Scope (Current_Scope) /= Standard_Standard + if Ada_Version >= Ada_2005 + and then Nkind (Specification (N)) = N_Procedure_Specification + and then Null_Present (Specification (N)) then - Body_To_Inline := Copy_Generic_Node (N, Empty, True); - else - Body_To_Inline := Copy_Separate_Tree (N); + Error_Msg_N + ("null procedure cannot be declared at library level", N); end if; + end if; - -- A pragma Unreferenced or pragma Unmodified that mentions a formal - -- parameter has no meaning when the body is inlined and the formals - -- are rewritten. Remove it from body to inline. The analysis of the - -- non-inlined body will handle the pragma properly. - - Remove_Pragmas (Body_To_Inline); - - -- We need to capture references to the formals in order - -- to substitute the actuals at the point of inlining, i.e. - -- instantiation. To treat the formals as globals to the body to - -- inline, we nest it within a dummy parameterless subprogram, - -- declared within the real one. + Generate_Reference_To_Formals (Designator); + Check_Eliminated (Designator); - Set_Parameter_Specifications - (Specification (Body_To_Inline), No_List); + if Debug_Flag_C then + Outdent; + Write_Str ("<== subprogram spec "); + Write_Name (Chars (Designator)); + Write_Str (" from "); + Write_Location (Sloc (N)); + Write_Eol; + end if; - -- A new internal name is associated with Body_To_Inline to avoid - -- conflicts when the non-inlined body N is analyzed. + if Is_Protected_Type (Current_Scope) then - Set_Defining_Unit_Name (Specification (Body_To_Inline), - Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); - Set_Corresponding_Spec (Body_To_Inline, Empty); - end Generate_Body_To_Inline; + -- Indicate that this is a protected operation, because it may be + -- used in subsequent declarations within the protected type. - ---------------------------------- - -- Split_Unconstrained_Function -- - ---------------------------------- + Set_Convention (Designator, Convention_Protected); + end if; - procedure Split_Unconstrained_Function - (N : Node_Id; - Spec_Id : Entity_Id) - is - Loc : constant Source_Ptr := Sloc (N); - Ret_Node : constant Node_Id := - First (Statements (Handled_Statement_Sequence (N))); - Ret_Obj : constant Node_Id := - First (Return_Object_Declarations (Ret_Node)); - - procedure Build_Procedure - (Proc_Id : out Entity_Id; - Decl_List : out List_Id); - -- Build a procedure containing the statements found in the extended - -- return statement of the unconstrained function body N. - - procedure Build_Procedure - (Proc_Id : out Entity_Id; - Decl_List : out List_Id) - is - Formal : Entity_Id; - Formal_List : constant List_Id := New_List; - Proc_Spec : Node_Id; - Proc_Body : Node_Id; - Subp_Name : constant Name_Id := New_Internal_Name ('F'); - Body_Decl_List : List_Id := No_List; - Param_Type : Node_Id; + List_Inherited_Pre_Post_Aspects (Designator); - begin - if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then - Param_Type := New_Copy (Object_Definition (Ret_Obj)); - else - Param_Type := - New_Copy (Subtype_Mark (Object_Definition (Ret_Obj))); - end if; + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Designator); + end if; + end Analyze_Subprogram_Declaration; - Append_To (Formal_List, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Ret_Obj))), - In_Present => False, - Out_Present => True, - Null_Exclusion_Present => False, - Parameter_Type => Param_Type)); - - Formal := First_Formal (Spec_Id); - while Present (Formal) loop - Append_To (Formal_List, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Sloc (Formal), - Chars => Chars (Formal)), - In_Present => In_Present (Parent (Formal)), - Out_Present => Out_Present (Parent (Formal)), - Null_Exclusion_Present => - Null_Exclusion_Present (Parent (Formal)), - Parameter_Type => - New_Occurrence_Of (Etype (Formal), Loc), - Expression => - Copy_Separate_Tree (Expression (Parent (Formal))))); + -------------------------------------- + -- Analyze_Subprogram_Specification -- + -------------------------------------- - Next_Formal (Formal); - end loop; + -- Reminder: N here really is a subprogram specification (not a subprogram + -- declaration). This procedure is called to analyze the specification in + -- both subprogram bodies and subprogram declarations (specs). - Proc_Id := - Make_Defining_Identifier (Loc, Chars => Subp_Name); + function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is + Designator : constant Entity_Id := Defining_Entity (N); + Formals : constant List_Id := Parameter_Specifications (N); - Proc_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc_Id, - Parameter_Specifications => Formal_List); + -- Start of processing for Analyze_Subprogram_Specification - Decl_List := New_List; + begin + -- User-defined operator is not allowed in SPARK, except as a renaming - Append_To (Decl_List, - Make_Subprogram_Declaration (Loc, Proc_Spec)); + if Nkind (Defining_Unit_Name (N)) = N_Defining_Operator_Symbol + and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration + then + Check_SPARK_05_Restriction + ("user-defined operator is not allowed", N); + end if; - -- Can_Convert_Unconstrained_Function checked that the function - -- has no local declarations except implicit label declarations. - -- Copy these declarations to the built procedure. + -- Proceed with analysis. Do not emit a cross-reference entry if the + -- specification comes from an expression function, because it may be + -- the completion of a previous declaration. It is is not, the cross- + -- reference entry will be emitted for the new subprogram declaration. - if Present (Declarations (N)) then - Body_Decl_List := New_List; + if Nkind (Parent (N)) /= N_Expression_Function then + Generate_Definition (Designator); + end if; - declare - D : Node_Id; - New_D : Node_Id; + Set_Contract (Designator, Make_Contract (Sloc (Designator))); - begin - D := First (Declarations (N)); - while Present (D) loop - pragma Assert (Nkind (D) = N_Implicit_Label_Declaration); - - New_D := - Make_Implicit_Label_Declaration (Loc, - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (D))), - Label_Construct => Empty); - Append_To (Body_Decl_List, New_D); - - Next (D); - end loop; - end; - end if; + if Nkind (N) = N_Function_Specification then + Set_Ekind (Designator, E_Function); + Set_Mechanism (Designator, Default_Mechanism); + else + Set_Ekind (Designator, E_Procedure); + Set_Etype (Designator, Standard_Void_Type); + end if; - pragma Assert (Present (Handled_Statement_Sequence (Ret_Node))); + -- Flag Is_Inlined_Always is True by default, and reversed to False for + -- those subprograms which could be inlined in GNATprove mode (because + -- Body_To_Inline is non-Empty) but cannot be inlined. - Proc_Body := - Make_Subprogram_Body (Loc, - Specification => Copy_Separate_Tree (Proc_Spec), - Declarations => Body_Decl_List, - Handled_Statement_Sequence => - Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node))); + if GNATprove_Mode then + Set_Is_Inlined_Always (Designator); + end if; - Set_Defining_Unit_Name (Specification (Proc_Body), - Make_Defining_Identifier (Loc, Subp_Name)); + -- Introduce new scope for analysis of the formals and the return type - Append_To (Decl_List, Proc_Body); - end Build_Procedure; + Set_Scope (Designator, Current_Scope); - -- Local variables + if Present (Formals) then + Push_Scope (Designator); + Process_Formals (Formals, N); - New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj); - Blk_Stmt : Node_Id; - Proc_Id : Entity_Id; - Proc_Call : Node_Id; + -- Check dimensions in N for formals with default expression - -- Start of processing for Split_Unconstrained_Function + Analyze_Dimension_Formals (N, Formals); - begin - -- Build the associated procedure, analyze it and insert it before - -- the function body N + -- Ada 2005 (AI-345): If this is an overriding operation of an + -- inherited interface operation, and the controlling type is + -- a synchronized type, replace the type with its corresponding + -- record, to match the proper signature of an overriding operation. + -- Same processing for an access parameter whose designated type is + -- derived from a synchronized interface. - declare - Scope : constant Entity_Id := Current_Scope; - Decl_List : List_Id; - begin - Pop_Scope; - Build_Procedure (Proc_Id, Decl_List); - Insert_Actions (N, Decl_List); - Push_Scope (Scope); - end; + if Ada_Version >= Ada_2005 then + declare + Formal : Entity_Id; + Formal_Typ : Entity_Id; + Rec_Typ : Entity_Id; + Desig_Typ : Entity_Id; - -- Build the call to the generated procedure + begin + Formal := First_Formal (Designator); + while Present (Formal) loop + Formal_Typ := Etype (Formal); - declare - Actual_List : constant List_Id := New_List; - Formal : Entity_Id; + if Is_Concurrent_Type (Formal_Typ) + and then Present (Corresponding_Record_Type (Formal_Typ)) + then + Rec_Typ := Corresponding_Record_Type (Formal_Typ); - begin - Append_To (Actual_List, - New_Occurrence_Of (Defining_Identifier (New_Obj), Loc)); + if Present (Interfaces (Rec_Typ)) then + Set_Etype (Formal, Rec_Typ); + end if; - Formal := First_Formal (Spec_Id); - while Present (Formal) loop - Append_To (Actual_List, New_Occurrence_Of (Formal, Loc)); + elsif Ekind (Formal_Typ) = E_Anonymous_Access_Type then + Desig_Typ := Designated_Type (Formal_Typ); - -- Avoid spurious warning on unreferenced formals + if Is_Concurrent_Type (Desig_Typ) + and then Present (Corresponding_Record_Type (Desig_Typ)) + then + Rec_Typ := Corresponding_Record_Type (Desig_Typ); - Set_Referenced (Formal); - Next_Formal (Formal); - end loop; + if Present (Interfaces (Rec_Typ)) then + Set_Directly_Designated_Type (Formal_Typ, Rec_Typ); + end if; + end if; + end if; - Proc_Call := - Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc_Id, Loc), - Parameter_Associations => Actual_List); - end; + Next_Formal (Formal); + end loop; + end; + end if; - -- Generate + End_Scope; - -- declare - -- New_Obj : ... - -- begin - -- main_1__F1b (New_Obj, ...); - -- return Obj; - -- end B10b; + -- The subprogram scope is pushed and popped around the processing of + -- the return type for consistency with call above to Process_Formals + -- (which itself can call Analyze_Return_Type), and to ensure that any + -- itype created for the return type will be associated with the proper + -- scope. - Blk_Stmt := - Make_Block_Statement (Loc, - Declarations => New_List (New_Obj), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( + elsif Nkind (N) = N_Function_Specification then + Push_Scope (Designator); + Analyze_Return_Type (N); + End_Scope; + end if; - Proc_Call, + -- Function case - Make_Simple_Return_Statement (Loc, - Expression => - New_Occurrence_Of - (Defining_Identifier (New_Obj), Loc))))); + if Nkind (N) = N_Function_Specification then - Rewrite (Ret_Node, Blk_Stmt); - end Split_Unconstrained_Function; + -- Deal with operator symbol case - -- Start of processing for Check_And_Build_Body_To_Inline + if Nkind (Designator) = N_Defining_Operator_Symbol then + Valid_Operator_Definition (Designator); + end if; - begin - -- Do not inline any subprogram that contains nested subprograms, since - -- the backend inlining circuit seems to generate uninitialized - -- references in this case. We know this happens in the case of front - -- end ZCX support, but it also appears it can happen in other cases as - -- well. The backend often rejects attempts to inline in the case of - -- nested procedures anyway, so little if anything is lost by this. - -- Note that this is test is for the benefit of the back-end. There is - -- a separate test for front-end inlining that also rejects nested - -- subprograms. - - -- Do not do this test if errors have been detected, because in some - -- error cases, this code blows up, and we don't need it anyway if - -- there have been errors, since we won't get to the linker anyway. - - if Comes_From_Source (Body_Id) - and then (Has_Pragma_Inline_Always (Spec_Id) - or else Optimization_Level > 0) - and then Serious_Errors_Detected = 0 - then - declare - P_Ent : Node_Id; + May_Need_Actuals (Designator); - begin - P_Ent := Body_Id; - loop - P_Ent := Scope (P_Ent); - exit when No (P_Ent) or else P_Ent = Standard_Standard; + -- Ada 2005 (AI-251): If the return type is abstract, verify that + -- the subprogram is abstract also. This does not apply to renaming + -- declarations, where abstractness is inherited, and to subprogram + -- bodies generated for stream operations, which become renamings as + -- bodies. - if Is_Subprogram (P_Ent) then - Set_Is_Inlined (P_Ent, False); + -- In case of primitives associated with abstract interface types + -- the check is applied later (see Analyze_Subprogram_Declaration). - if Comes_From_Source (P_Ent) - and then Has_Pragma_Inline (P_Ent) - then - Cannot_Inline - ("cannot inline& (nested subprogram)?", N, P_Ent, - Is_Serious => True); - end if; - end if; - end loop; - end; - end if; + if not Nkind_In (Original_Node (Parent (N)), + N_Subprogram_Renaming_Declaration, + N_Abstract_Subprogram_Declaration, + N_Formal_Abstract_Subprogram_Declaration) + then + if Is_Abstract_Type (Etype (Designator)) + and then not Is_Interface (Etype (Designator)) + then + Error_Msg_N + ("function that returns abstract type must be abstract", N); - -- Build the body to inline only if really needed + -- Ada 2012 (AI-0073): Extend this test to subprograms with an + -- access result whose designated type is abstract. - if Check_Body_To_Inline (N, Spec_Id) - and then Serious_Errors_Detected = 0 - then - if Returns_Unconstrained_Type (Spec_Id) then - if Can_Split_Unconstrained_Function (N) then - Split_Unconstrained_Function (N, Spec_Id); - Build_Body_To_Inline (N, Spec_Id); - Set_Is_Inlined (Spec_Id); + elsif Nkind (Result_Definition (N)) = N_Access_Definition + and then + not Is_Class_Wide_Type (Designated_Type (Etype (Designator))) + and then Is_Abstract_Type (Designated_Type (Etype (Designator))) + and then Ada_Version >= Ada_2012 + then + Error_Msg_N ("function whose access result designates " + & "abstract type must be abstract", N); end if; - else - Build_Body_To_Inline (N, Spec_Id); - Set_Is_Inlined (Spec_Id); end if; end if; - end Check_And_Build_Body_To_Inline; + + return Designator; + end Analyze_Subprogram_Specification; ----------------------- -- Check_Conformance -- @@ -6179,7 +4741,7 @@ package body Sem_Ch6 is -- this before checking that the types of the formals match. if Chars (Old_Formal) /= Chars (New_Formal) then - Conformance_Error ("\name & does not match!", New_Formal); + Conformance_Error ("\name& does not match!", New_Formal); -- Set error posted flag on new formal as well to stop -- junk cascaded messages in some cases. @@ -6202,7 +4764,7 @@ package body Sem_Ch6 is Comes_From_Source (New_Formal) then Conformance_Error - ("\null exclusion for & does not match", New_Formal); + ("\null exclusion for& does not match", New_Formal); -- Mark error posted on the new formal to avoid duplicated -- complaint about types not matching. @@ -6338,8 +4900,7 @@ package body Sem_Ch6 is declare T : constant Entity_Id := Find_Dispatching_Type (New_Id); begin - if Is_Protected_Type - (Corresponding_Concurrent_Type (T)) + if Is_Protected_Type (Corresponding_Concurrent_Type (T)) then Error_Msg_PT (T, New_Id); else @@ -6412,9 +4973,9 @@ package body Sem_Ch6 is if Is_Controlling_Formal (New_Formal) then Error_Msg_Node_2 := Scope (New_Formal); Conformance_Error - ("\controlling formal& of& excludes null, " - & "declaration must exclude null as well", - New_Formal); + ("\controlling formal & of & excludes null, " + & "declaration must exclude null as well", + New_Formal); -- Normal case (couldn't we give more detail here???) @@ -6608,23 +5169,21 @@ package body Sem_Ch6 is Error_Msg_N ("\\primitive % defined #", Typ); else Error_Msg_N - ("\\overriding operation % with " & - "convention % defined #", Typ); + ("\\overriding operation % with " + & "convention % defined #", Typ); end if; else pragma Assert (Present (Alias (Op))); Error_Msg_Sloc := Sloc (Alias (Op)); - Error_Msg_N - ("\\inherited operation % with " & - "convention % defined #", Typ); + Error_Msg_N ("\\inherited operation % with " + & "convention % defined #", Typ); end if; Error_Msg_Name_1 := Chars (Op); Error_Msg_Name_2 := Get_Convention_Name (Iface_Conv); Error_Msg_Sloc := Sloc (Iface_Prim); - Error_Msg_N - ("\\overridden operation % with " & - "convention % defined #", Typ); + Error_Msg_N ("\\overridden operation % with " + & "convention % defined #", Typ); -- Avoid cascading errors @@ -7155,9 +5714,8 @@ package body Sem_Ch6 is if not Is_Primitive and then Ekind (Scope (Subp)) /= E_Protected_Type then - Error_Msg_N - ("overriding indicator only allowed " - & "if subprogram is primitive", Subp); + Error_Msg_N ("overriding indicator only allowed " + & "if subprogram is primitive", Subp); elsif Can_Override_Operator (Subp) then Error_Msg_NE @@ -8518,7 +7076,7 @@ package body Sem_Ch6 is then if Scope (E) /= Standard_Standard then Error_Msg_Sloc := Sloc (E); - Error_Msg_N ("declaration of & hides one#?h?", S); + Error_Msg_N ("declaration of & hides one #?h?", S); elsif Nkind (S) = N_Defining_Operator_Symbol and then @@ -8542,8 +7100,8 @@ package body Sem_Ch6 is Obj_Decl : Node_Id; begin - -- This check applies only if we have a subprogram declaration with a - -- non-tagged record type. + -- This check applies only if we have a subprogram declaration with an + -- untagged record type. if Nkind (Decl) /= N_Subprogram_Declaration or else not Is_Record_Type (Typ) @@ -8592,7 +7150,7 @@ package body Sem_Ch6 is else if Ada_Version >= Ada_2012 then Error_Msg_NE - ("equality operator must be declared before type& is " + ("equality operator must be declared before type & is " & "frozen (RM 4.5.2 (9.8)) (Ada 2012)<<", Eq_Op, Typ); -- In Ada 2012 mode with error turned to warning, output one @@ -8708,21 +7266,38 @@ package body Sem_Ch6 is -- Check that the types of corresponding formals have the same -- generic actual if any. We have to account for subtypes of a -- generic formal, declared between a spec and a body, which may - -- appear distinct in an instance but matched in the generic. + -- appear distinct in an instance but matched in the generic, and + -- the subtype may be used either in the spec or the body of the + -- subprogram being checked. ------------------------- -- Same_Generic_Actual -- ------------------------- function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean is + + function Is_Declared_Subtype (S1, S2 : Entity_Id) return Boolean; + -- Predicate to check whether S1 is a subtype of S2 in the source + -- of the instance. + + ------------------------- + -- Is_Declared_Subtype -- + ------------------------- + + function Is_Declared_Subtype (S1, S2 : Entity_Id) return Boolean is + begin + return Comes_From_Source (Parent (S1)) + and then Nkind (Parent (S1)) = N_Subtype_Declaration + and then Is_Entity_Name (Subtype_Indication (Parent (S1))) + and then Entity (Subtype_Indication (Parent (S1))) = S2; + end Is_Declared_Subtype; + + -- Start of processing for Same_Generic_Actual + begin return Is_Generic_Actual_Type (T1) = Is_Generic_Actual_Type (T2) - or else - (Present (Parent (T1)) - and then Comes_From_Source (Parent (T1)) - and then Nkind (Parent (T1)) = N_Subtype_Declaration - and then Is_Entity_Name (Subtype_Indication (Parent (T1))) - and then Entity (Subtype_Indication (Parent (T1))) = T2); + or else Is_Declared_Subtype (T1, T2) + or else Is_Declared_Subtype (T2, T1); end Same_Generic_Actual; -- Start of processing for Different_Generic_Profile @@ -9811,8 +8386,8 @@ package body Sem_Ch6 is then Error_Msg_Node_2 := F_Typ; Error_Msg_NE - ("private operation& in generic unit does not override " & - "any primitive operation of& (RM 12.3 (18))??", + ("private operation& in generic unit does not override " + & "any primitive operation of& (RM 12.3 (18))??", New_E, New_E); end if; @@ -9845,13 +8420,11 @@ package body Sem_Ch6 is if Class_Present (P) and then not Split_PPC (P) then if Pragma_Name (P) = Name_Precondition then - Error_Msg_N - ("info: & inherits `Pre''Class` aspect from #?L?", - E); + Error_Msg_N ("info: & inherits `Pre''Class` aspect " + & "from #?L?", E); else - Error_Msg_N - ("info: & inherits `Post''Class` aspect from #?L?", - E); + Error_Msg_N ("info: & inherits `Post''Class` aspect " + & "from #?L?", E); end if; end if; @@ -10079,18 +8652,15 @@ package body Sem_Ch6 is and then (not Is_Overriding or else not Is_Abstract_Subprogram (E)) then - Error_Msg_N - ("abstract subprograms must be visible " - & "(RM 3.9.3(10))!", S); + Error_Msg_N ("abstract subprograms must be visible " + & "(RM 3.9.3(10))!", S); elsif Ekind (S) = E_Function and then not Is_Overriding then if Is_Tagged_Type (T) and then T = Base_Type (Etype (S)) then - Error_Msg_N - ("private function with tagged result must" - & " override visible-part function", S); - Error_Msg_N - ("\move subprogram to the visible part" - & " (RM 3.9.3(10))", S); + Error_Msg_N ("private function with tagged result must" + & " override visible-part function", S); + Error_Msg_N ("\move subprogram to the visible part" + & " (RM 3.9.3(10))", S); -- AI05-0073: extend this test to the case of a function -- with a controlling access result. @@ -10103,10 +8673,10 @@ package body Sem_Ch6 is then Error_Msg_N ("private function with controlling access result " - & "must override visible-part function", S); + & "must override visible-part function", S); Error_Msg_N ("\move subprogram to the visible part" - & " (RM 3.9.3(10))", S); + & " (RM 3.9.3(10))", S); end if; end if; end if; @@ -10631,7 +9201,6 @@ 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)) @@ -10847,7 +9416,7 @@ package body Sem_Ch6 is or else Is_Abstract_Subprogram (S) or else (Is_Dispatching_Operation (E) - and then Is_Overriding_Alias (E, S))) + and then Is_Overriding_Alias (E, S))) and then Ekind (E) /= E_Enumeration_Literal then -- When an derived operation is overloaded it may be due to @@ -11189,7 +9758,7 @@ package body Sem_Ch6 is if Nkind (S) /= N_Defining_Operator_Symbol then Error_Msg_Sloc := Sloc (Homonym (S)); - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("overloading not allowed with entity#", S); end if; @@ -11328,10 +9897,11 @@ package body Sem_Ch6 is -- dependents of the type. if Is_Tagged_Type (Formal_Type) - or else Ada_Version >= Ada_2012 + or else (Ada_Version >= Ada_2012 + and then not From_Limited_With (Formal_Type) + and then not Is_Generic_Type (Formal_Type)) then if Ekind (Scope (Current_Scope)) = E_Package - and then not From_Limited_With (Formal_Type) and then not Is_Generic_Type (Formal_Type) and then not Is_Class_Wide_Type (Formal_Type) then @@ -11341,7 +9911,7 @@ package body Sem_Ch6 is then Append_Elmt (Current_Scope, - Private_Dependents (Base_Type (Formal_Type))); + To => Private_Dependents (Base_Type (Formal_Type))); -- Freezing is delayed to ensure that Register_Prim -- will get called for this operation, which is needed @@ -11363,13 +9933,29 @@ package body Sem_Ch6 is then -- AI05-0151: Tagged incomplete types are allowed in all -- formal parts. Untagged incomplete types are not allowed - -- in bodies. + -- in bodies. Limited views of either kind are not allowed + -- if there is no place at which the non-limited view can + -- become available. - if Ada_Version >= Ada_2012 then - if Is_Tagged_Type (Formal_Type) then + -- Incomplete formal untagged types are not allowed in + -- subprogram bodies (but are legal in their declarations). + + if Is_Generic_Type (Formal_Type) + and then not Is_Tagged_Type (Formal_Type) + and then Nkind (Parent (Related_Nod)) = N_Subprogram_Body + then + Error_Msg_N + ("invalid use of formal incomplete type", Param_Spec); + + elsif Ada_Version >= Ada_2012 then + if Is_Tagged_Type (Formal_Type) + and then (not From_Limited_With (Formal_Type) + or else not In_Package_Body) + then null; elsif Nkind_In (Parent (Parent (T)), N_Accept_Statement, + N_Accept_Alternative, N_Entry_Body, N_Subprogram_Body) then @@ -11482,7 +10068,7 @@ package body Sem_Ch6 is Default := Expression (Param_Spec); if Present (Default) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("default expression is not allowed", Default); if Out_Present (Param_Spec) then @@ -11505,8 +10091,8 @@ package body Sem_Ch6 is and then Is_Access_Constant (Etype (Default)) then Error_Msg_N - ("formal that is access to variable cannot be initialized " & - "with an access-to-constant expression", Default); + ("formal that is access to variable cannot be initialized " + & "with an access-to-constant expression", Default); end if; -- Check that the designated type of an access parameter's default @@ -11555,21 +10141,22 @@ package body Sem_Ch6 is ("function cannot have parameter of mode `OUT` or " & "`IN OUT`", Formal); - -- A function cannot have a volatile formal parameter - -- (SPARK RM 7.1.3(10)). + -- A function cannot have an effectively volatile formal + -- parameter (SPARK RM 7.1.3(10)). - elsif Is_SPARK_Volatile (Formal) then + elsif Is_Effectively_Volatile (Formal) then Error_Msg_N ("function cannot have a volatile formal parameter", Formal); end if; - -- A procedure cannot have a formal parameter of mode IN because - -- it behaves as a constant (SPARK RM 7.1.3(6)). + -- A procedure cannot have an effectively volatile formal + -- parameter of mode IN because it behaves as a constant + -- (SPARK RM 7.1.3(6)). elsif Ekind (Scope (Formal)) = E_Procedure and then Ekind (Formal) = E_In_Parameter - and then Is_SPARK_Volatile (Formal) + and then Is_Effectively_Volatile (Formal) then Error_Msg_N ("formal parameter of mode `IN` cannot be volatile", Formal); @@ -11700,11 +10287,11 @@ package body Sem_Ch6 is ------------------------- procedure Set_Actual_Subtypes (N : Node_Id; Subp : Entity_Id) is - Decl : Node_Id; - Formal : Entity_Id; - T : Entity_Id; - First_Stmt : Node_Id := Empty; - AS_Needed : Boolean; + Decl : Node_Id; + Formal : Entity_Id; + T : Entity_Id; + First_Stmt : Node_Id := Empty; + AS_Needed : Boolean; begin -- If this is an empty initialization procedure, no need to create @@ -11991,7 +10578,6 @@ package body Sem_Ch6 is Result : Boolean; begin May_Hide_Profile := False; - Check_Conformance (New_Id, Old_Id, Type_Conformant, False, Result, Skip_Controlling_Formals => Skip_Controlling_Formals); @@ -12017,6 +10603,14 @@ package body Sem_Ch6 is Error_Msg_N ("default values not allowed for operator parameters", Parent (F)); + + -- For function instantiations that are operators, we must check + -- separately that the corresponding generic only has in-parameters. + -- For subprogram declarations this is done in Set_Formal_Mode. Such + -- an error could not arise in earlier versions of the language. + + elsif Ekind (F) /= E_In_Parameter then + Error_Msg_N ("operators can only have IN parameters", F); end if; Next_Formal (F); @@ -12049,7 +10643,7 @@ package body Sem_Ch6 is and then not Is_Intrinsic_Subprogram (Designator) then Error_Msg_N - ("explicit definition of inequality not allowed", Designator); + ("explicit definition of inequality not allowed", Designator); end if; end Valid_Operator_Definition; diff --git a/main/gcc/ada/sem_ch6.ads b/main/gcc/ada/sem_ch6.ads index 67bb65268a4..5a29d378dc8 100644 --- a/main/gcc/ada/sem_ch6.ads +++ b/main/gcc/ada/sem_ch6.ads @@ -68,39 +68,6 @@ package Sem_Ch6 is -- and body declarations. Returns the defining entity for the -- specification N. - procedure Cannot_Inline - (Msg : String; - N : Node_Id; - Subp : Entity_Id; - Is_Serious : Boolean := False); - -- This procedure is called if the node N, an instance of a call to - -- subprogram Subp, cannot be inlined. Msg is the message to be issued, - -- which ends with ? (it does not end with ?p?, this routine takes care of - -- the need to change ? to ?p?). Temporarily the behavior of this routine - -- depends on the value of -gnatd.k: - -- - -- * If -gnatd.k is not set (ie. old inlining model) then if Subp has - -- a pragma Always_Inlined, then an error message is issued (by - -- removing the last character of Msg). If Subp is not Always_Inlined, - -- then a warning is issued if the flag Ineffective_Inline_Warnings - -- is set, adding ?p to the msg, and if not, the call has no effect. - -- - -- * If -gnatd.k is set (ie. new inlining model) then: - -- - If Is_Serious is true, then an error is reported (by removing the - -- last character of Msg); - -- - -- - otherwise: - -- - -- * Compiling without optimizations if Subp has a pragma - -- Always_Inlined, then an error message is issued; if Subp is - -- not Always_Inlined, then a warning is issued if the flag - -- Ineffective_Inline_Warnings is set (adding p?), and if not, - -- the call has no effect. - -- - -- * Compiling with optimizations then a warning is issued if the - -- flag Ineffective_Inline_Warnings is set (adding p?); otherwise - -- no effect since inlining may be performed by the backend. - procedure Check_Conventions (Typ : Entity_Id); -- Ada 2005 (AI-430): Check that the conventions of all inherited and -- overridden dispatching operations of type Typ are consistent with their diff --git a/main/gcc/ada/sem_ch7.adb b/main/gcc/ada/sem_ch7.adb index 099bbd74d10..4821db529c8 100644 --- a/main/gcc/ada/sem_ch7.adb +++ b/main/gcc/ada/sem_ch7.adb @@ -281,8 +281,7 @@ package body Sem_Ch7 is else Spec_Id := Current_Entity_In_Scope (Defining_Entity (N)); - if Present (Spec_Id) - and then Is_Package_Or_Generic_Package (Spec_Id) + if Present (Spec_Id) and then Is_Package_Or_Generic_Package (Spec_Id) then Pack_Decl := Unit_Declaration_Node (Spec_Id); @@ -438,9 +437,7 @@ package body Sem_Ch7 is Inspect_Deferred_Constant_Completion (Declarations (N)); end if; - -- After declarations have been analyzed, the body has been set to have - -- the final value of SPARK_Mode. Check that the SPARK_Mode for the body - -- is consistent with the SPARK_Mode for the spec. + -- Verify that the SPARK_Mode of the body agrees with that of its spec if Present (SPARK_Pragma (Body_Id)) then if Present (SPARK_Aux_Pragma (Spec_Id)) then @@ -701,8 +698,7 @@ package body Sem_Ch7 is -- of accessing global entities. if Has_Pragma_Inline (E) then - if Outer - and then Check_Subprogram_Refs (D) = OK + if Outer and then Check_Subprogram_Refs (D) = OK then Has_Referencer_Except_For_Subprograms := True; else @@ -724,8 +720,7 @@ package body Sem_Ch7 is end if; if Has_Pragma_Inline (E) or else Is_Inlined (E) then - if Outer - and then Check_Subprogram_Refs (D) = OK + if Outer and then Check_Subprogram_Refs (D) = OK then Has_Referencer_Except_For_Subprograms := True; else @@ -1096,7 +1091,7 @@ package body Sem_Ch7 is else Error_Msg_Sloc := Sloc (Previous); - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("at most one tagged type or type extension allowed", "\\ previous declaration#", Decl); @@ -1353,8 +1348,9 @@ package body Sem_Ch7 is Analyze_Declarations (Vis_Decls); end if; - -- Verify that incomplete types have received full declarations and - -- also build invariant procedures for any types with invariants. + -- Inspect the entities defined in the package and ensure that all + -- incomplete types have received full declarations. Build default + -- initial condition and invariant procedures for all qualifying types. E := First_Entity (Id); while Present (E) loop @@ -1370,10 +1366,26 @@ package body Sem_Ch7 is Error_Msg_N ("no declaration in visible part for incomplete}", E); end if; - -- Build invariant procedures + if Is_Type (E) then - if Is_Type (E) and then Has_Invariants (E) then - Build_Invariant_Procedure (E, N); + -- 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 Has_Invariants (E) then + Build_Invariant_Procedure (E, N); + end if; end if; Next_Entity (E); @@ -1890,7 +1902,7 @@ package body Sem_Ch7 is end if; else - -- Non-tagged type, scan forward to locate inherited hidden + -- For untagged type, scan forward to locate inherited hidden -- operations. Prim_Op := Next_Entity (E); @@ -1982,10 +1994,19 @@ package body Sem_Ch7 is Write_Eol; end if; - if not Is_Child_Unit (Id) then + if Is_Child_Unit (Id) then + null; + + -- Do not enter implicitly inherited non-overridden subprograms of + -- a tagged type back into visibility if they have non-conformant + -- homographs (Ada RM 8.3 12.3/2). + + elsif Is_Hidden_Non_Overridden_Subpgm (Id) then + null; + + else Set_Is_Immediately_Visible (Id); end if; - end if; end Install_Package_Entity; @@ -2022,8 +2043,7 @@ package body Sem_Ch7 is -- field. This field will be empty if the entity has already been -- installed due to a previous call. - if Present (Full_View (Priv)) - and then Is_Visible_Dependent (Priv) + if Present (Full_View (Priv)) and then Is_Visible_Dependent (Priv) then if Is_Private_Type (Priv) then Deps := Private_Dependents (Priv); @@ -2073,8 +2093,8 @@ package body Sem_Ch7 is Id := First_Entity (P); while Present (Id) and then Id /= First_Private_Entity (P) loop if Is_Private_Base_Type (Id) - and then Comes_From_Source (Full_View (Id)) and then Present (Full_View (Id)) + and then Comes_From_Source (Full_View (Id)) and then Scope (Full_View (Id)) = Scope (Id) and then Ekind (Full_View (Id)) /= E_Incomplete_Type then @@ -2369,11 +2389,14 @@ package body Sem_Ch7 is if Priv_Is_Base_Type then Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full))); - Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only - (Base_Type (Full))); - Set_Has_Task (Priv, Has_Task (Base_Type (Full))); - Set_Has_Controlled_Component (Priv, Has_Controlled_Component - (Base_Type (Full))); + 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))); + Set_Has_Controlled_Component + (Priv, Has_Controlled_Component + (Base_Type (Full))); end if; Set_Freeze_Node (Priv, Freeze_Node (Full)); @@ -2457,9 +2480,9 @@ package body Sem_Ch7 is or else Type_In_Use (Etype (Id)) or else Type_In_Use (Etype (First_Formal (Id))) or else (Present (Next_Formal (First_Formal (Id))) - and then - Type_In_Use - (Etype (Next_Formal (First_Formal (Id)))))); + and then + Type_In_Use + (Etype (Next_Formal (First_Formal (Id)))))); else if In_Use (P) and then not Is_Hidden (Id) then @@ -2640,7 +2663,7 @@ package body Sem_Ch7 is -- The following test may be redundant, as this is already -- diagnosed in sem_ch3. ??? - if Is_Indefinite_Subtype (Full) + if Is_Indefinite_Subtype (Full) and then not Is_Indefinite_Subtype (Id) then Error_Msg_Sloc := Sloc (Parent (Id)); @@ -2815,8 +2838,7 @@ package body Sem_Ch7 is elsif Ekind_In (P, E_Generic_Package, E_Package) and then not Ignore_Abstract_State and then Present (Abstract_States (P)) - and then - not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) + and then not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) then return True; end if; @@ -2943,8 +2965,7 @@ package body Sem_Ch7 is elsif Ekind_In (P, E_Generic_Package, E_Package) and then Present (Abstract_States (P)) - and then - not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) + and then not Is_Null_State (Node (First_Elmt (Abstract_States (P)))) then Error_Msg_N ("info: & requires body (non-null abstract state aspect)?Y?", P); @@ -3006,12 +3027,10 @@ package body Sem_Ch7 is or else (Is_Generic_Subprogram (E) and then not Has_Completion (E)) - then Error_Msg_Node_2 := E; Error_Msg_NE - ("info: & requires body (& requires completion)?Y?", - E, P); + ("info: & requires body (& requires completion)?Y?", E, P); -- Entity that does not require completion diff --git a/main/gcc/ada/sem_ch8.adb b/main/gcc/ada/sem_ch8.adb index e085cd203c0..655f38bf6f4 100644 --- a/main/gcc/ada/sem_ch8.adb +++ b/main/gcc/ada/sem_ch8.adb @@ -552,13 +552,12 @@ package body Sem_Ch8 is Nam : constant Node_Id := Name (N); begin - Check_SPARK_Restriction ("exception renaming is not allowed", N); + Check_SPARK_05_Restriction ("exception renaming is not allowed", N); Enter_Name (Id); Analyze (Nam); Set_Ekind (Id, E_Exception); - Set_Exception_Code (Id, Uint_0); Set_Etype (Id, Standard_Exception_Type); Set_Is_Pure (Id, Is_Pure (Current_Scope)); @@ -659,7 +658,7 @@ package body Sem_Ch8 is return; end if; - Check_SPARK_Restriction ("generic renaming is not allowed", N); + Check_SPARK_05_Restriction ("generic renaming is not allowed", N); Generate_Definition (New_P); @@ -837,7 +836,7 @@ package body Sem_Ch8 is return; end if; - Check_SPARK_Restriction ("object renaming is not allowed", N); + Check_SPARK_05_Restriction ("object renaming is not allowed", N); Set_Is_Pure (Id, Is_Pure (Current_Scope)); Enter_Name (Id); @@ -1008,10 +1007,10 @@ package body Sem_Ch8 is Resolve (Nam, T); - -- Ada 2005 (AI-231): "In the case where the type is defined by an + -- 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) + -- access-to-constant type. ARM 8.5.1(4) if Constant_Present (Access_Definition (N)) and then not Is_Access_Constant (Etype (Nam)) @@ -1245,17 +1244,17 @@ package body Sem_Ch8 is elsif Nkind (Original_Node (Nam)) = N_Function_Call - -- When expansion is disabled, attribute reference is not - -- rewritten as function call. Otherwise it may be rewritten - -- as a conversion, so check original node. + -- When expansion is disabled, attribute reference is not rewritten + -- as function call. Otherwise it may be rewritten as a conversion, + -- so check original node. or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference and then Is_Function_Attribute_Name (Attribute_Name (Original_Node (Nam)))) - -- Weird but legal, equivalent to renaming a function call. - -- Illegal if the literal is the result of constant-folding an - -- attribute reference that is not a function. + -- Weird but legal, equivalent to renaming a function call. Illegal + -- if the literal is the result of constant-folding an attribute + -- reference that is not a function. or else (Is_Entity_Name (Nam) and then Ekind (Entity (Nam)) = E_Enumeration_Literal @@ -1296,6 +1295,28 @@ package body Sem_Ch8 is Set_Is_True_Constant (Id, True); 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. + + Set_Is_Volatile (Id, Is_Volatile_Object (Nam)); + + -- Treat as volatile if we just set the Volatile flag + + if Is_Volatile (Id) + + -- Or if we are renaming an entity which was marked this way + + -- Are there more cases, e.g. X(J) where X is Treat_As_Volatile ??? + + or else (Is_Entity_Name (Nam) + and then Treat_As_Volatile (Entity (Nam))) + then + Set_Treat_As_Volatile (Id, True); + end if; + + -- Now make the link to the renamed object + Set_Renamed_Object (Id, Nam); -- Implementation-defined aspect specifications can appear in a renaming @@ -1791,18 +1812,51 @@ package body Sem_Ch8 is --------------------------------- procedure Analyze_Subprogram_Renaming (N : Node_Id) is - Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N); - Is_Actual : constant Boolean := Present (Formal_Spec); - Inst_Node : Node_Id := Empty; + Formal_Spec : constant Entity_Id := Corresponding_Formal_Spec (N); + Is_Actual : constant Boolean := Present (Formal_Spec); Nam : constant Node_Id := Name (N); - New_S : Entity_Id; - Old_S : Entity_Id := Empty; - Rename_Spec : Entity_Id; Save_AV : constant Ada_Version_Type := Ada_Version; Save_AVP : constant Node_Id := Ada_Version_Pragma; Save_AV_Exp : constant Ada_Version_Type := Ada_Version_Explicit; Spec : constant Node_Id := Specification (N); + Old_S : Entity_Id := Empty; + Rename_Spec : Entity_Id; + + procedure Build_Class_Wide_Wrapper + (Ren_Id : out Entity_Id; + Wrap_Id : out Entity_Id); + -- Ada 2012 (AI05-0071): A generic/instance scenario involving a formal + -- type with unknown discriminants and a generic primitive operation of + -- the said type with a box require special processing when the actual + -- is a class-wide type: + -- + -- generic + -- type Formal_Typ (<>) is private; + -- with procedure Prim_Op (Param : Formal_Typ) is <>; + -- package Gen is ... + -- + -- package Inst is new Gen (Actual_Typ'Class); + -- + -- In this case the general renaming mechanism used in the prologue of + -- an instance no longer applies: + -- + -- procedure Prim_Op (Param : Formal_Typ) renames Prim_Op; + -- + -- The above is replaced the following wrapper/renaming combination: + -- + -- procedure Wrapper (Param : Formal_Typ) is -- wrapper + -- begin + -- Prim_Op (Param); -- primitive + -- end Wrapper; + -- + -- procedure Prim_Op (Param : Formal_Typ) renames Wrapper; + -- + -- 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). + procedure Check_Null_Exclusion (Ren : Entity_Id; Sub : Entity_Id); @@ -1824,6 +1878,11 @@ package body Sem_Ch8 is -- types: a callable entity freezes its profile, unless it has an -- incomplete untagged formal (RM 13.14(10.2/3)). + function Has_Class_Wide_Actual return Boolean; + -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a + -- defaulted formal subprogram where the actual for the controlling + -- formal type is class-wide. + function Original_Subprogram (Subp : Entity_Id) return Entity_Id; -- Find renamed entity when the declaration is a renaming_as_body and -- the renamed entity may itself be a renaming_as_body. Used to enforce @@ -1831,187 +1890,454 @@ package body Sem_Ch8 is -- before the subprogram it completes is frozen, and renaming indirectly -- renames the subprogram itself.(Defect Report 8652/0027). - function Check_Class_Wide_Actual return Entity_Id; - -- AI05-0071: In an instance, if the actual for a formal type FT with - -- unknown discriminants is a class-wide type CT, and the generic has - -- a formal subprogram with a box for a primitive operation of FT, - -- then the corresponding actual subprogram denoted by the default is a - -- class-wide operation whose body is a dispatching call. We replace the - -- generated renaming declaration: - -- - -- procedure P (X : CT) renames P; - -- - -- by a different renaming and a class-wide operation: - -- - -- procedure Pr (X : T) renames P; -- renames primitive operation - -- procedure P (X : CT); -- class-wide operation - -- ... - -- procedure P (X : CT) is begin Pr (X); end; -- dispatching call - -- - -- This rule only applies if there is no explicit visible class-wide - -- operation at the point of the instantiation. + ------------------------------ + -- Build_Class_Wide_Wrapper -- + ------------------------------ - function Has_Class_Wide_Actual return Boolean; - -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a - -- defaulted formal subprogram when the actual for the controlling - -- formal type is class-wide. + procedure Build_Class_Wide_Wrapper + (Ren_Id : out Entity_Id; + Wrap_Id : out Entity_Id) + is + Loc : constant Source_Ptr := Sloc (N); - ----------------------------- - -- Check_Class_Wide_Actual -- - ----------------------------- + function Build_Call + (Subp_Id : Entity_Id; + Params : List_Id) return Node_Id; + -- Create a dispatching call to invoke routine Subp_Id with actuals + -- built from the parameter specifications of list Params. - function Check_Class_Wide_Actual return Entity_Id is - Loc : constant Source_Ptr := Sloc (N); + function Build_Spec (Subp_Id : Entity_Id) return Node_Id; + -- Create a subprogram specification based on the subprogram profile + -- of Subp_Id. + + function Find_Primitive (Typ : Entity_Id) return Entity_Id; + -- Find a primitive subprogram of type Typ which matches the profile + -- of the renaming declaration. - F : Entity_Id; - Formal_Type : Entity_Id; - Actual_Type : Entity_Id; - New_Body : Node_Id; - New_Decl : Node_Id; - Result : Entity_Id; + procedure Interpretation_Error (Subp_Id : Entity_Id); + -- Emit a continuation error message suggesting subprogram Subp_Id as + -- a possible interpretation. - function Make_Call (Prim_Op : Entity_Id) return Node_Id; - -- Build dispatching call for body of class-wide operation + function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id denotes the intrinsic "=" + -- operator. - function Make_Spec return Node_Id; - -- Create subprogram specification for declaration and body of - -- class-wide operation, using signature of renaming declaration. + function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean; + -- Determine whether subprogram Subp_Id is a suitable candidate for + -- the role of a wrapped subprogram. - --------------- - -- Make_Call -- - --------------- + ---------------- + -- Build_Call -- + ---------------- - function Make_Call (Prim_Op : Entity_Id) return Node_Id is - Actuals : List_Id; - F : Node_Id; + function Build_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 - Actuals := New_List; - F := First (Parameter_Specifications (Specification (New_Decl))); - while Present (F) loop + -- Build the actual parameters of the call + + Formal := First (Params); + while Present (Formal) loop Append_To (Actuals, - Make_Identifier (Loc, Chars (Defining_Identifier (F)))); - Next (F); + Make_Identifier (Loc, Chars (Defining_Identifier (Formal)))); + Next (Formal); end loop; - if Ekind_In (Prim_Op, E_Function, E_Operator) then - return Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Prim_Op, Loc), - Parameter_Associations => Actuals)); + -- Generate: + -- return Subp_Id (Actuals); + + if Ekind_In (Subp_Id, E_Function, E_Operator) then + return + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => Call_Ref, + Parameter_Associations => Actuals)); + + -- Generate: + -- Subp_Id (Actuals); + else return Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Prim_Op, Loc), - Parameter_Associations => Actuals); + Name => Call_Ref, + Parameter_Associations => Actuals); end if; - end Make_Call; + end Build_Call; - --------------- - -- Make_Spec -- - --------------- + ---------------- + -- Build_Spec -- + ---------------- - function Make_Spec return Node_Id is - Param_Specs : constant List_Id := Copy_Parameter_List (New_S); + function Build_Spec (Subp_Id : Entity_Id) return Node_Id is + Params : constant List_Id := Copy_Parameter_List (Subp_Id); + Spec_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Subp_Id), 'R')); begin - if Ekind (New_S) = E_Procedure then + if Ekind (Formal_Spec) = E_Procedure then return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars (Defining_Unit_Name (Spec))), - Parameter_Specifications => Param_Specs); + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Params); else return - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars (Defining_Unit_Name (Spec))), - Parameter_Specifications => Param_Specs, - Result_Definition => - New_Copy_Tree (Result_Definition (Spec))); + Make_Function_Specification (Loc, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Params, + Result_Definition => + New_Copy_Tree (Result_Definition (Spec))); + end if; + end Build_Spec; + + -------------------- + -- Find_Primitive -- + -------------------- + + function Find_Primitive (Typ : Entity_Id) return Entity_Id is + procedure Replace_Parameter_Types (Spec : Node_Id); + -- Given a specification Spec, replace all class-wide parameter + -- types with reference to type Typ. + + ----------------------------- + -- Replace_Parameter_Types -- + ----------------------------- + + procedure Replace_Parameter_Types (Spec : Node_Id) is + Formal : Node_Id; + Formal_Id : Entity_Id; + Formal_Typ : Node_Id; + + begin + Formal := First (Parameter_Specifications (Spec)); + while Present (Formal) loop + Formal_Id := Defining_Identifier (Formal); + Formal_Typ := Parameter_Type (Formal); + + -- Create a new entity for each class-wide formal to prevent + -- aliasing with the original renaming. Replace the type of + -- such a parameter with the candidate type. + + if Nkind (Formal_Typ) = N_Identifier + and then Is_Class_Wide_Type (Etype (Formal_Typ)) + then + Set_Defining_Identifier (Formal, + Make_Defining_Identifier (Loc, Chars (Formal_Id))); + + Set_Parameter_Type (Formal, New_Occurrence_Of (Typ, Loc)); + end if; + + Next (Formal); + end loop; + end Replace_Parameter_Types; + + -- Local variables + + Alt_Ren : constant Node_Id := New_Copy_Tree (N); + Alt_Nam : constant Node_Id := Name (Alt_Ren); + Alt_Spec : constant Node_Id := Specification (Alt_Ren); + Subp_Id : Entity_Id; + + -- Start of processing for Find_Primitive + + begin + -- Each attempt to find a suitable primitive of a particular type + -- operates on its own copy of the original renaming. As a result + -- the original renaming is kept decoration and side-effect free. + + -- Inherit the overloaded status of the renamed subprogram name + + if Is_Overloaded (Nam) then + Set_Is_Overloaded (Alt_Nam); + Save_Interps (Nam, Alt_Nam); + end if; + + -- The copied renaming is hidden from visibility to prevent the + -- pollution of the enclosing context. + + Set_Defining_Unit_Name (Alt_Spec, Make_Temporary (Loc, 'R')); + + -- The types of all class-wide parameters must be changed to the + -- candidate type. + + Replace_Parameter_Types (Alt_Spec); + + -- Try to find a suitable primitive which matches the altered + -- profile of the renaming specification. + + Subp_Id := + Find_Renamed_Entity + (N => Alt_Ren, + Nam => Name (Alt_Ren), + New_S => Analyze_Subprogram_Specification (Alt_Spec), + Is_Actual => Is_Actual); + + -- Do not return Any_Id if the resolion of the altered profile + -- failed as this complicates further checks on the caller side, + -- return Empty instead. + + if Subp_Id = Any_Id then + return Empty; + else + return Subp_Id; + end if; + end Find_Primitive; + + -------------------------- + -- Interpretation_Error -- + -------------------------- + + procedure Interpretation_Error (Subp_Id : Entity_Id) is + begin + Error_Msg_Sloc := Sloc (Subp_Id); + + if Is_Internal (Subp_Id) then + Error_Msg_NE + ("\\possible interpretation: predefined & #", + Spec, Formal_Spec); + else + Error_Msg_NE + ("\\possible interpretation: & defined #", Spec, Formal_Spec); + end if; + end Interpretation_Error; + + --------------------------- + -- Is_Intrinsic_Equality -- + --------------------------- + + function Is_Intrinsic_Equality (Subp_Id : Entity_Id) return Boolean is + begin + return + Ekind (Subp_Id) = E_Operator + and then Chars (Subp_Id) = Name_Op_Eq + and then Is_Intrinsic_Subprogram (Subp_Id); + end Is_Intrinsic_Equality; + + --------------------------- + -- Is_Suitable_Candidate -- + --------------------------- + + function Is_Suitable_Candidate (Subp_Id : Entity_Id) return Boolean is + begin + if No (Subp_Id) then + return False; + + -- An intrinsic subprogram is never a good candidate. This is an + -- indication of a missing primitive, either defined directly or + -- inherited from a parent tagged type. + + elsif Is_Intrinsic_Subprogram (Subp_Id) then + return False; + + else + return True; end if; - end Make_Spec; + end Is_Suitable_Candidate; + + -- Local variables - -- Start of processing for Check_Class_Wide_Actual + Actual_Typ : Entity_Id := Empty; + -- The actual class-wide type for Formal_Typ + + CW_Prim_OK : Boolean; + CW_Prim_Op : Entity_Id; + -- The class-wide subprogram (if available) which corresponds to the + -- renamed generic formal subprogram. + + Formal_Typ : Entity_Id := Empty; + -- The generic formal type with unknown discriminants + + Root_Prim_OK : Boolean; + Root_Prim_Op : Entity_Id; + -- The root type primitive (if available) which corresponds to the + -- renamed generic formal subprogram. + + Root_Typ : Entity_Id := Empty; + -- The root type of Actual_Typ + + Body_Decl : Node_Id; + Formal : Node_Id; + Prim_Op : Entity_Id; + Spec_Decl : Node_Id; + + -- Start of processing for Build_Class_Wide_Wrapper begin - Result := Any_Id; - Formal_Type := Empty; - Actual_Type := Empty; - - F := First_Formal (Formal_Spec); - while Present (F) loop - if Has_Unknown_Discriminants (Etype (F)) - and then not Is_Class_Wide_Type (Etype (F)) - and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F))) + -- Analyze the specification of the renaming in case the generation + -- of the class-wide wrapper fails. + + Ren_Id := Analyze_Subprogram_Specification (Spec); + Wrap_Id := Any_Id; + + -- Do not attempt to build a wrapper if the renaming is in error + + if Error_Posted (Nam) then + return; + end if; + + -- Analyze the renamed name, but do not resolve it. The resolution is + -- completed once a suitable subprogram is found. + + Analyze (Nam); + + -- When the renamed name denotes the intrinsic operator equals, the + -- name must be treated as overloaded. This allows for a potential + -- match against the root type's predefined equality function. + + if Is_Intrinsic_Equality (Entity (Nam)) then + Set_Is_Overloaded (Nam); + Collect_Interps (Nam); + end if; + + -- Step 1: Find the generic formal type with unknown discriminants + -- and its corresponding class-wide actual type from the renamed + -- generic formal subprogram. + + Formal := First_Formal (Formal_Spec); + while Present (Formal) loop + if Has_Unknown_Discriminants (Etype (Formal)) + and then not Is_Class_Wide_Type (Etype (Formal)) + and then Is_Class_Wide_Type (Get_Instance_Of (Etype (Formal))) then - Formal_Type := Etype (F); - Actual_Type := Etype (Get_Instance_Of (Formal_Type)); + Formal_Typ := Etype (Formal); + Actual_Typ := Get_Instance_Of (Formal_Typ); + Root_Typ := Etype (Actual_Typ); exit; end if; - Next_Formal (F); + Next_Formal (Formal); end loop; - if Present (Formal_Type) then + -- The specification of the generic formal subprogram should always + -- contain a formal type with unknown discriminants whose actual is + -- a class-wide type, otherwise this indicates a failure in routine + -- Has_Class_Wide_Actual. - -- Create declaration and body for class-wide operation + pragma Assert (Present (Formal_Typ)); - New_Decl := - Make_Subprogram_Declaration (Loc, Specification => Make_Spec); + -- Step 2: Find the proper class-wide subprogram or primitive which + -- corresponds to the renamed generic formal subprogram. - New_Body := - Make_Subprogram_Body (Loc, - Specification => Make_Spec, - Declarations => No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, New_List)); + CW_Prim_Op := Find_Primitive (Actual_Typ); + CW_Prim_OK := Is_Suitable_Candidate (CW_Prim_Op); + Root_Prim_Op := Find_Primitive (Root_Typ); + Root_Prim_OK := Is_Suitable_Candidate (Root_Prim_Op); - -- Modify Spec and create internal name for renaming of primitive - -- operation. + -- The class-wide actual type has two subprograms which correspond to + -- the renamed generic formal subprogram: - Set_Defining_Unit_Name (Spec, Make_Temporary (Loc, 'R')); - F := First (Parameter_Specifications (Spec)); - while Present (F) loop - if Nkind (Parameter_Type (F)) = N_Identifier - and then Is_Class_Wide_Type (Entity (Parameter_Type (F))) - then - Set_Parameter_Type (F, New_Occurrence_Of (Actual_Type, Loc)); - end if; - Next (F); - end loop; + -- with procedure Prim_Op (Param : Formal_Typ); - New_S := Analyze_Subprogram_Specification (Spec); - Result := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual); - end if; + -- procedure Prim_Op (Param : Actual_Typ); -- may be inherited + -- procedure Prim_Op (Param : Actual_Typ'Class); + + -- Even though the declaration of the two subprograms is legal, a + -- call to either one is ambiguous and therefore illegal. + + if CW_Prim_OK and Root_Prim_OK then + + -- A user-defined primitive has precedence over a predefined one - if Result /= Any_Id then - Insert_Before (N, New_Decl); - Analyze (New_Decl); + if Is_Internal (CW_Prim_Op) + and then not Is_Internal (Root_Prim_Op) + then + Prim_Op := Root_Prim_Op; - -- Add dispatching call to body of class-wide operation + elsif Is_Internal (Root_Prim_Op) + and then not Is_Internal (CW_Prim_Op) + then + Prim_Op := CW_Prim_Op; - Append (Make_Call (Result), - Statements (Handled_Statement_Sequence (New_Body))); + elsif CW_Prim_Op = Root_Prim_Op then + Prim_Op := Root_Prim_Op; - -- The generated body does not freeze. It is analyzed when the - -- generated operation is frozen. This body is only needed if - -- expansion is enabled. + -- Otherwise both candidate subprograms are user-defined and + -- ambiguous. - if Expander_Active then - Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + else + Error_Msg_NE + ("ambiguous actual for generic subprogram &", + Spec, Formal_Spec); + Interpretation_Error (Root_Prim_Op); + Interpretation_Error (CW_Prim_Op); + return; end if; - Result := Defining_Entity (New_Decl); + elsif CW_Prim_OK and not Root_Prim_OK then + Prim_Op := CW_Prim_Op; + + elsif not CW_Prim_OK and Root_Prim_OK then + Prim_Op := Root_Prim_Op; + + -- An intrinsic equality may act as a suitable candidate in the case + -- of a null type extension where the parent's equality is hidden. A + -- call to an intrinsic equality is expanded as dispatching. + + elsif Present (Root_Prim_Op) + and then Is_Intrinsic_Equality (Root_Prim_Op) + then + Prim_Op := Root_Prim_Op; + + -- Otherwise there are no candidate subprograms. Let the caller + -- diagnose the error. + + else + return; + end if; + + -- At this point resolution has taken place and the name is no longer + -- overloaded. Mark the primitive as referenced. + + Set_Is_Overloaded (Name (N), False); + Set_Referenced (Prim_Op); + + -- 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); + + -- 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)))))); + + -- The generated body does not freeze and must be analyzed when the + -- class-wide wrapper is frozen. The body is only needed if expansion + -- is enabled. + + if Expander_Active then + Append_Freeze_Action (Wrap_Id, Body_Decl); end if; - -- Return the class-wide operation if one was created + -- Step 4: The subprogram renaming aliases the wrapper - return Result; - end Check_Class_Wide_Actual; + Rewrite (Nam, New_Occurrence_Of (Wrap_Id, Loc)); + end Build_Class_Wide_Wrapper; -------------------------- -- Check_Null_Exclusion -- @@ -2097,7 +2423,6 @@ package body Sem_Ch8 is if Is_Incomplete_Or_Private_Type (Etype (F)) and then No (Underlying_Type (Etype (F))) then - -- Exclude generic types, or types derived from them. -- They will be frozen in the enclosing instance. @@ -2123,28 +2448,23 @@ package body Sem_Ch8 is --------------------------- function Has_Class_Wide_Actual return Boolean is - F_Nam : Entity_Id; - F_Spec : Entity_Id; + Formal : Entity_Id; + Formal_Typ : Entity_Id; begin - if Is_Actual - and then Nkind (Nam) in N_Has_Entity - and then Present (Entity (Nam)) - and then Is_Dispatching_Operation (Entity (Nam)) - then - F_Nam := First_Entity (Entity (Nam)); - F_Spec := First_Formal (Formal_Spec); - while Present (F_Nam) and then Present (F_Spec) loop - if Is_Controlling_Formal (F_Nam) - and then Has_Unknown_Discriminants (Etype (F_Spec)) - and then not Is_Class_Wide_Type (Etype (F_Spec)) - and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F_Spec))) + if Is_Actual then + Formal := First_Formal (Formal_Spec); + while Present (Formal) loop + Formal_Typ := Etype (Formal); + + if Has_Unknown_Discriminants (Formal_Typ) + and then not Is_Class_Wide_Type (Formal_Typ) + and then Is_Class_Wide_Type (Get_Instance_Of (Formal_Typ)) then return True; end if; - Next_Entity (F_Nam); - Next_Formal (F_Spec); + Next_Formal (Formal); end loop; end if; @@ -2194,11 +2514,16 @@ package body Sem_Ch8 is end if; end Original_Subprogram; + -- Local variables + CW_Actual : constant Boolean := Has_Class_Wide_Actual; -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a -- defaulted formal subprogram when the actual for a related formal -- type is class-wide. + Inst_Node : Node_Id := Empty; + New_S : Entity_Id; + -- Start of processing for Analyze_Subprogram_Renaming begin @@ -2323,9 +2648,8 @@ package body Sem_Ch8 is -- Check whether the renaming is for a defaulted actual subprogram -- with a class-wide actual. - if CW_Actual then - New_S := Analyze_Subprogram_Specification (Spec); - Old_S := Check_Class_Wide_Actual; + if CW_Actual and then Box_Present (Inst_Node) then + Build_Class_Wide_Wrapper (New_S, Old_S); elsif Is_Entity_Name (Nam) and then Present (Entity (Nam)) @@ -2602,8 +2926,8 @@ package body Sem_Ch8 is Analyze_Renamed_Character (N, New_S, Present (Rename_Spec)); return; - -- Only remaining case is where we have a non-entity name, or a - -- renaming of some other non-overloadable entity. + -- Only remaining case is where we have a non-entity name, or a renaming + -- of some other non-overloadable entity. elsif not Is_Entity_Name (Nam) or else not Is_Overloadable (Entity (Nam)) @@ -3108,7 +3432,7 @@ package body Sem_Ch8 is -- Start of processing for Analyze_Use_Package begin - Check_SPARK_Restriction ("use clause is not allowed", N); + Check_SPARK_05_Restriction ("use clause is not allowed", N); Set_Hidden_By_Use_Clause (N, No_Elist); @@ -3366,12 +3690,11 @@ package body Sem_Ch8 is -- This procedure is called in the context of subprogram renaming, and -- thus the attribute must be one that is a subprogram. All of those - -- have at least one formal parameter, with the exceptions of AST_Entry - -- (which is a real oddity, it is odd that this can be renamed at all) - -- and the GNAT attribute 'Img, which GNAT treats as renameable. + -- have at least one formal parameter, with the exceptions of the GNAT + -- attribute 'Img, which GNAT treats as renameable. if not Is_Non_Empty_List (Parameter_Specifications (Spec)) then - if Aname /= Name_AST_Entry and then Aname /= Name_Img then + if Aname /= Name_Img then Error_Msg_N ("subprogram renaming an attribute must have formals", N); return; @@ -3441,46 +3764,18 @@ package body Sem_Ch8 is end if; end if; - -- AST_Entry is an odd case. It doesn't really make much sense to allow - -- it to be renamed, but that's the DEC rule, so we have to do it right. - -- The point is that the AST_Entry call should be made now, and what the - -- function will return is the returned value. - - -- Note that there is no Expr_List in this case anyway - - if Aname = Name_AST_Entry then - declare - Ent : constant Entity_Id := Make_Temporary (Loc, 'R', Nam); - Decl : Node_Id; - - begin - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Ent, - Object_Definition => - New_Occurrence_Of (RTE (RE_AST_Handler), Loc), - Expression => Nam, - Constant_Present => True); - - Set_Assignment_OK (Decl, True); - Insert_Action (N, Decl); - Attr_Node := Make_Identifier (Loc, Chars (Ent)); - end; - - -- For all other attributes, we rewrite the attribute node to have - -- a list of expressions corresponding to the subprogram formals. - -- A renaming declaration is not a freeze point, and the analysis of - -- the attribute reference should not freeze the type of the prefix. - -- We use the original node in the renaming so that its source location - -- is preserved, and checks on stream attributes are properly applied. + -- Rewrite attribute node to have a list of expressions corresponding to + -- the subprogram formals. A renaming declaration is not a freeze point, + -- and the analysis of the attribute reference should not freeze the + -- type of the prefix. We use the original node in the renaming so that + -- its source location is preserved, and checks on stream attributes are + -- properly applied. - else - Attr_Node := Relocate_Node (Nam); - Set_Expressions (Attr_Node, Expr_List); + Attr_Node := Relocate_Node (Nam); + Set_Expressions (Attr_Node, Expr_List); - Set_Must_Not_Freeze (Attr_Node); - Set_Must_Not_Freeze (Prefix (Nam)); - end if; + Set_Must_Not_Freeze (Attr_Node); + Set_Must_Not_Freeze (Prefix (Nam)); -- Case of renaming a function @@ -3525,7 +3820,7 @@ package body Sem_Ch8 is -- In case of tagged types we add the body of the generated function to -- the freezing actions of the type (because in the general case such -- type is still not frozen). We exclude from this processing generic - -- formal subprograms found in instantiations and AST_Entry renamings. + -- formal subprograms found in instantiations. -- We must exclude VM targets and restricted run-time libraries because -- entity AST_Handler is defined in package System.Aux_Dec which is not @@ -3947,7 +4242,6 @@ package body Sem_Ch8 is else Pop_Scope; end if; - end End_Scope; --------------------- @@ -4218,14 +4512,14 @@ package body Sem_Ch8 is -- for that processing function Known_But_Invisible (E : Entity_Id) return Boolean; - -- This function determines whether the entity E (which is not - -- visible) can reasonably be considered to be known to the writer - -- of the reference. This is a heuristic test, used only for the - -- purposes of figuring out whether we prefer to complain that an - -- entity is undefined or invisible (and identify the declaration - -- of the invisible entity in the latter case). The point here is - -- that we don't want to complain that something is invisible and - -- then point to something entirely mysterious to the writer. + -- This function determines whether a reference to the entity E, which + -- is not visible, can reasonably be considered to be known to the + -- writer of the reference. This is a heuristic test, used only for + -- the purposes of figuring out whether we prefer to complain that an + -- entity is undefined or invisible (and identify the declaration of + -- the invisible entity in the latter case). The point here is that we + -- don't want to complain that something is invisible and then point to + -- something entirely mysterious to the writer. procedure Nvis_Messages; -- Called if there are no visible entries for N, but there is at least @@ -4364,7 +4658,12 @@ package body Sem_Ch8 is elsif not Comes_From_Source (E) then return False; - -- In gnat internal mode, we consider all entities known + -- In gnat internal mode, we consider all entities known. The + -- historical reason behind this discrepancy is not known??? But the + -- only effect is to modify the error message given, so it is not + -- critical. Since it only affects the exact wording of error + -- messages in illegal programs, we do not mention this as an + -- effect of -gnatg, since it is not a language modification. elsif GNAT_Mode then return True; @@ -5924,31 +6223,11 @@ package body Sem_Ch8 is Old_S := Any_Id; Candidate_Renaming := Empty; - if not Is_Overloaded (Nam) then - if Is_Actual and then Present (Enclosing_Instance) then - Old_S := Entity (Nam); - - elsif Entity_Matches_Spec (Entity (Nam), New_S) then - Candidate_Renaming := New_S; - - if Is_Visible_Operation (Entity (Nam)) then - Old_S := Entity (Nam); - end if; - - elsif - Present (First_Formal (Entity (Nam))) - and then Present (First_Formal (New_S)) - and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = - Base_Type (Etype (First_Formal (New_S)))) - then - Candidate_Renaming := Entity (Nam); - end if; - - else + if Is_Overloaded (Nam) then Get_First_Interp (Nam, Ind, It); while Present (It.Nam) loop if Entity_Matches_Spec (It.Nam, New_S) - and then Is_Visible_Operation (It.Nam) + and then Is_Visible_Operation (It.Nam) then if Old_S /= Any_Id then @@ -6017,6 +6296,27 @@ package body Sem_Ch8 is if Old_S /= Any_Id then Set_Is_Overloaded (Nam, False); end if; + + -- Non-overloaded case + + else + if Is_Actual and then Present (Enclosing_Instance) then + Old_S := Entity (Nam); + + elsif Entity_Matches_Spec (Entity (Nam), New_S) then + Candidate_Renaming := New_S; + + if Is_Visible_Operation (Entity (Nam)) then + Old_S := Entity (Nam); + end if; + + elsif Present (First_Formal (Entity (Nam))) + and then Present (First_Formal (New_S)) + and then (Base_Type (Etype (First_Formal (Entity (Nam)))) = + Base_Type (Etype (First_Formal (New_S)))) + then + Candidate_Renaming := Entity (Nam); + end if; end if; return Old_S; @@ -6094,12 +6394,13 @@ package body Sem_Ch8 is if Restriction_Check_Required (SPARK_05) then if Nkind (Selector_Name (N)) = N_Character_Literal then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("character literal cannot be prefixed", N); elsif Nkind (Selector_Name (N)) = N_Operator_Symbol and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration then - Check_SPARK_Restriction ("operator symbol cannot be prefixed", N); + Check_SPARK_05_Restriction + ("operator symbol cannot be prefixed", N); end if; end if; @@ -6244,6 +6545,25 @@ package body Sem_Ch8 is Write_Entity_Info (P_Type, " "); Write_Eol; end if; + -- 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 instlling the context. + + if Is_Access_Type (P_Type) then + declare + D : constant Entity_Id := Directly_Designated_Type (P_Type); + begin + if Is_Incomplete_Type (D) + and then not Is_Class_Wide_Type (D) + and then From_Limited_With (D) + and then Present (Non_Limited_View (D)) + and then not Is_Class_Wide_Type (Non_Limited_View (D)) + then + Set_Directly_Designated_Type (P_Type, Non_Limited_View (D)); + end if; + end; + end if; + -- First check for components of a record object (not the -- result of a call, which is handled below). @@ -6448,10 +6768,10 @@ package body Sem_Ch8 is and then Restriction_Check_Required (SPARK_05) then if Is_Subprogram (P_Name) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("prefix of expanded name cannot be a subprogram", P); elsif Ekind (P_Name) = E_Loop then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("prefix of expanded name cannot be a loop statement", P); end if; end if; @@ -6610,7 +6930,7 @@ package body Sem_Ch8 is elsif Attribute_Name (N) = Name_Base then Error_Msg_Name_1 := Name_Base; - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("attribute% is only allowed as prefix of another attribute", N); if Ada_Version = Ada_83 and then Comes_From_Source (N) then @@ -7533,6 +7853,8 @@ package body Sem_Ch8 is Default_Pool := SST.Save_Default_Storage_Pool; SPARK_Mode := SST.Save_SPARK_Mode; SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma; + Default_SSO := SST.Save_Default_SSO; + Uneval_Old := SST.Save_Uneval_Old; if Debug_Flag_W then Write_Str ("<-- exiting scope: "); @@ -7605,6 +7927,8 @@ package body Sem_Ch8 is SST.Save_Default_Storage_Pool := Default_Pool; SST.Save_SPARK_Mode := SPARK_Mode; SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma; + SST.Save_Default_SSO := Default_SSO; + SST.Save_Uneval_Old := Uneval_Old; if Scope_Stack.Last > Scope_Stack.First then SST.Component_Alignment_Default := Scope_Stack.Table @@ -7620,6 +7944,7 @@ package body Sem_Ch8 is SST.First_Use_Clause := Empty; SST.Is_Active_Stack_Base := False; SST.Previous_Visibility := False; + SST.Locked_Shared_Objects := No_Elist; end; if Debug_Flag_W then diff --git a/main/gcc/ada/sem_ch9.adb b/main/gcc/ada/sem_ch9.adb index fb479561ed4..6be4f559a6c 100644 --- a/main/gcc/ada/sem_ch9.adb +++ b/main/gcc/ada/sem_ch9.adb @@ -304,7 +304,8 @@ package body Sem_Ch9 is if Is_Scalar_Type (Etype (Attr)) and then Is_Scalar_Type (Etype (Prefix (Attr))) - and then Is_Static_Subtype (Etype (Prefix (Attr))) + and then + Is_OK_Static_Subtype (Etype (Prefix (Attr))) then Para := First (Expressions (Attr)); @@ -389,7 +390,7 @@ package body Sem_Ch9 is -- static function restricted. elsif Kind = N_Attribute_Reference - and then not Is_Static_Expression (N) + and then not Is_OK_Static_Expression (N) and then not Is_Static_Function (N) then if Lock_Free_Given then @@ -427,7 +428,7 @@ package body Sem_Ch9 is -- Non-static function calls restricted elsif Kind = N_Function_Call - and then not Is_Static_Expression (N) + and then not Is_OK_Static_Expression (N) then if Lock_Free_Given then Error_Msg_N @@ -700,7 +701,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("abort statement is not allowed", N); + Check_SPARK_05_Restriction ("abort statement is not allowed", N); T_Name := First (Names (N)); while Present (T_Name) loop @@ -771,7 +772,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("accept statement is not allowed", N); + Check_SPARK_05_Restriction ("accept statement is not allowed", N); -- Entry name is initialized to Any_Id. It should get reset to the -- matching entry entity. An error is signalled if it is not reset. @@ -1002,7 +1003,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("select statement is not allowed", N); + Check_SPARK_05_Restriction ("select statement is not allowed", N); Check_Restriction (Max_Asynchronous_Select_Nesting, N); Check_Restriction (No_Select_Statements, N); @@ -1048,7 +1049,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("select statement is not allowed", N); + Check_SPARK_05_Restriction ("select statement is not allowed", N); Check_Restriction (No_Select_Statements, N); -- Ada 2005 (AI-345): The trigger may be a dispatching call @@ -1145,7 +1146,7 @@ package body Sem_Ch9 is E : constant Node_Id := Expression (N); begin Tasking_Used := True; - Check_SPARK_Restriction ("delay statement is not allowed", N); + Check_SPARK_05_Restriction ("delay statement is not allowed", N); Check_Restriction (No_Relative_Delay, N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); @@ -1163,7 +1164,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("delay statement is not allowed", N); + Check_SPARK_05_Restriction ("delay statement is not allowed", N); Check_Restriction (No_Delay, N); Check_Potentially_Blocking_Operation (N); Analyze (E); @@ -1452,7 +1453,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("entry call is not allowed", N); + Check_SPARK_05_Restriction ("entry call is not allowed", N); if Present (Pragmas_Before (N)) then Analyze_List (Pragmas_Before (N)); @@ -1557,7 +1558,7 @@ package body Sem_Ch9 is goto Skip_LB; end if; - if Is_Static_Expression (LBR) + if Is_OK_Static_Expression (LBR) and then Expr_Value (LBR) < LB then Error_Msg_Uint_1 := LB; @@ -1583,7 +1584,7 @@ package body Sem_Ch9 is goto Skip_UB; end if; - if Is_Static_Expression (UBR) + if Is_OK_Static_Expression (UBR) and then Expr_Value (UBR) > UB then Error_Msg_Uint_1 := UB; @@ -1885,7 +1886,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("protected definition is not allowed", N); + Check_SPARK_05_Restriction ("protected definition is not allowed", N); Analyze_Declarations (Visible_Declarations (N)); if Present (Private_Declarations (N)) @@ -1911,6 +1912,11 @@ package body Sem_Ch9 is 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); end if; Next_Entity (E); @@ -1957,6 +1963,7 @@ package body Sem_Ch9 is Set_Ekind (T, E_Protected_Type); Set_Is_First_Subtype (T, True); + Set_Has_Protected (T, True); Init_Size_Align (T); Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); @@ -2169,7 +2176,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("requeue statement is not allowed", N); + Check_SPARK_05_Restriction ("requeue statement is not allowed", N); Check_Restriction (No_Requeue_Statements, N); Check_Unreachable_Code (N); @@ -2464,7 +2471,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("select statement is not allowed", N); + Check_SPARK_05_Restriction ("select statement is not allowed", N); Check_Restriction (No_Select_Statements, N); -- Loop to analyze alternatives @@ -2855,7 +2862,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("task definition is not allowed", N); + Check_SPARK_05_Restriction ("task definition is not allowed", N); if Present (Visible_Declarations (N)) then Analyze_Declarations (Visible_Declarations (N)); @@ -2889,6 +2896,17 @@ package body Sem_Ch9 is begin Check_Restriction (No_Tasking, N); Tasking_Used := True; + + -- The sequential partition elaboration policy is supported only in the + -- restricted profile. + + if Partition_Elaboration_Policy = 'S' + and then not Restricted_Profile + then + Error_Msg_N + ("sequential elaboration supported only in restricted profile", N); + end if; + T := Find_Type_Name (N); Generate_Definition (T); @@ -3027,7 +3045,7 @@ package body Sem_Ch9 is begin Tasking_Used := True; - Check_SPARK_Restriction ("select statement is not allowed", N); + Check_SPARK_05_Restriction ("select statement is not allowed", N); Check_Restriction (No_Select_Statements, N); -- Ada 2005 (AI-345): The trigger may be a dispatching call diff --git a/main/gcc/ada/sem_dim.adb b/main/gcc/ada/sem_dim.adb index 6bb74ee0714..37d2f7a9123 100644 --- a/main/gcc/ada/sem_dim.adb +++ b/main/gcc/ada/sem_dim.adb @@ -2262,10 +2262,14 @@ package body Sem_Dim is -- Provide minimal semantic information on dimension expressions, -- even though they have no run-time existence. This is for use by - -- ASIS tools, in particular pretty-printing. + -- ASIS tools, in particular pretty-printing. If generating code + -- standard operator resolution will take place. + + if ASIS_Mode then + Set_Entity (N, Standard_Op_Minus); + Set_Etype (N, Standard_Integer); + end if; - Set_Entity (N, Standard_Op_Minus); - Set_Etype (N, Standard_Integer); return Result; end Process_Minus; @@ -2294,10 +2298,14 @@ package body Sem_Dim is -- Provide minimal semantic information on dimension expressions, -- even though they have no run-time existence. This is for use by - -- ASIS tools, in particular pretty-printing. + -- ASIS tools, in particular pretty-printing. If generating code + -- standard operator resolution will take place. + + if ASIS_Mode then + Set_Entity (N, Standard_Op_Divide); + Set_Etype (N, Standard_Integer); + end if; - Set_Entity (N, Standard_Op_Divide); - Set_Etype (N, Standard_Integer); return Result; end Process_Divide; diff --git a/main/gcc/ada/sem_disp.adb b/main/gcc/ada/sem_disp.adb index b7647829c95..6d6078dc9f5 100644 --- a/main/gcc/ada/sem_disp.adb +++ b/main/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 @@ package body Sem_Disp is -- This routine does not search for non-hidden primitives since they are -- covered by the normal Ada 2005 rules. + function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean; + -- Check whether a primitive operation is inherited from an operation + -- declared in the visible part of its package. + ------------------------------- -- Add_Dispatching_Operation -- ------------------------------- @@ -1233,9 +1237,17 @@ package body Sem_Disp is Check_Subtype_Conformant (Subp, Ovr_Subp); + -- A primitive operation with the name of a primitive controlled + -- operation does not override a non-visible overriding controlled + -- operation, i.e. one declared in a private part when the full + -- view of a type is controlled. Conversely, it will override a + -- visible operation that may be declared in a partial view when + -- the full view is controlled. + if Nam_In (Chars (Subp), Name_Initialize, Name_Adjust, Name_Finalize) and then Is_Controlled (Tagged_Type) and then not Is_Visibly_Controlled (Tagged_Type) + and then not Is_Inherited_Public_Operation (Ovr_Subp) then Set_Overridden_Operation (Subp, Empty); @@ -2032,7 +2044,11 @@ package body Sem_Disp is -- Inherited_Subprograms -- --------------------------- - function Inherited_Subprograms (S : Entity_Id) return Subprogram_List is + function Inherited_Subprograms + (S : Entity_Id; + No_Interfaces : Boolean := False; + Interfaces_Only : Boolean := False) return Subprogram_List + is Result : Subprogram_List (1 .. 6000); -- 6000 here is intended to be infinity. We could use an expandable -- table, but it would be awfully heavy, and there is no way that we @@ -2066,68 +2082,79 @@ package body Sem_Disp is -- Start of processing for Inherited_Subprograms begin + pragma Assert (not (No_Interfaces and Interfaces_Only)); + if Present (S) and then Is_Dispatching_Operation (S) then -- Deal with direct inheritance - Parent_Op := S; - loop - Parent_Op := Overridden_Operation (Parent_Op); - exit when No (Parent_Op); - - if Is_Subprogram (Parent_Op) - or else Is_Generic_Subprogram (Parent_Op) - then - Store_IS (Parent_Op); - end if; - end loop; + if not Interfaces_Only then + Parent_Op := S; + loop + Parent_Op := Overridden_Operation (Parent_Op); + exit when No (Parent_Op) + or else + (No_Interfaces + and then + Is_Interface (Find_Dispatching_Type (Parent_Op))); + + if Is_Subprogram (Parent_Op) + or else + Is_Generic_Subprogram (Parent_Op) + then + Store_IS (Parent_Op); + end if; + end loop; + end if; -- Now deal with interfaces - declare - Tag_Typ : Entity_Id; - Prim : Entity_Id; - Elmt : Elmt_Id; + if not No_Interfaces then + declare + Tag_Typ : Entity_Id; + Prim : Entity_Id; + Elmt : Elmt_Id; - begin - Tag_Typ := Find_Dispatching_Type (S); + begin + Tag_Typ := Find_Dispatching_Type (S); - if Is_Concurrent_Type (Tag_Typ) then - Tag_Typ := Corresponding_Record_Type (Tag_Typ); - end if; + if Is_Concurrent_Type (Tag_Typ) then + Tag_Typ := Corresponding_Record_Type (Tag_Typ); + end if; - -- Search primitive operations of dispatching type + -- Search primitive operations of dispatching type - if Present (Tag_Typ) - and then Present (Primitive_Operations (Tag_Typ)) - then - Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); - while Present (Elmt) loop - Prim := Node (Elmt); + if Present (Tag_Typ) + and then Present (Primitive_Operations (Tag_Typ)) + then + Elmt := First_Elmt (Primitive_Operations (Tag_Typ)); + while Present (Elmt) loop + Prim := Node (Elmt); - -- The following test eliminates some odd cases in which - -- Ekind (Prim) is Void, to be investigated further ??? + -- The following test eliminates some odd cases in which + -- Ekind (Prim) is Void, to be investigated further ??? - if not (Is_Subprogram (Prim) - or else - Is_Generic_Subprogram (Prim)) - then - null; + if not (Is_Subprogram (Prim) + or else + Is_Generic_Subprogram (Prim)) + then + null; -- For [generic] subprogram, look at interface alias - elsif Present (Interface_Alias (Prim)) - and then Alias (Prim) = S - then - -- We have found a primitive covered by S + elsif Present (Interface_Alias (Prim)) + and then Alias (Prim) = S + then + -- We have found a primitive covered by S - Store_IS (Interface_Alias (Prim)); - end if; + Store_IS (Interface_Alias (Prim)); + end if; - Next_Elmt (Elmt); - end loop; - end if; - end; + Next_Elmt (Elmt); + end loop; + end if; + end; + end if; end if; return Result (1 .. N); @@ -2159,6 +2186,27 @@ package body Sem_Disp is and then Is_Interface (Find_Dispatching_Type (E)); end Is_Null_Interface_Primitive; + ----------------------------------- + -- Is_Inherited_Public_Operation -- + ----------------------------------- + + function Is_Inherited_Public_Operation (Op : Entity_Id) return Boolean is + Prim : constant Entity_Id := Alias (Op); + Scop : constant Entity_Id := Scope (Prim); + Pack_Decl : Node_Id; + + begin + if Comes_From_Source (Prim) and then Ekind (Scop) = E_Package then + Pack_Decl := Unit_Declaration_Node (Scop); + return Nkind (Pack_Decl) = N_Package_Declaration + and then List_Containing (Unit_Declaration_Node (Prim)) = + Visible_Declarations (Specification (Pack_Decl)); + + else + return False; + end if; + end Is_Inherited_Public_Operation; + -------------------------- -- Is_Tag_Indeterminate -- -------------------------- @@ -2222,8 +2270,7 @@ package body Sem_Disp is elsif Nkind (Orig_Node) = N_Attribute_Reference and then Get_Attribute_Id (Attribute_Name (Orig_Node)) = Attribute_Input - and then - Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference + and then Nkind (Prefix (Orig_Node)) /= N_Attribute_Reference then return True; @@ -2267,9 +2314,7 @@ package body Sem_Disp is -- was malformed, and an error must have been emitted already. Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); - while Present (Elmt) - and then Node (Elmt) /= Prev_Op - loop + while Present (Elmt) and then Node (Elmt) /= Prev_Op loop Next_Elmt (Elmt); end loop; @@ -2304,9 +2349,8 @@ package body Sem_Disp is Replace_Elmt (Elmt, New_Op); end if; - if Ada_Version >= Ada_2005 - and then Has_Interfaces (Tagged_Type) - then + if Ada_Version >= Ada_2005 and then Has_Interfaces (Tagged_Type) then + -- Ada 2005 (AI-251): Update the attribute alias of all the aliased -- entities of the overridden primitive to reference New_Op, and -- also propagate the proper value of Is_Abstract_Subprogram. Verify diff --git a/main/gcc/ada/sem_disp.ads b/main/gcc/ada/sem_disp.ads index ff1ebc4d7ee..7dbec1b1c91 100644 --- a/main/gcc/ada/sem_disp.ads +++ b/main/gcc/ada/sem_disp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,13 +97,22 @@ package Sem_Disp is type Subprogram_List is array (Nat range <>) of Entity_Id; -- Type returned by Inherited_Subprograms function - function Inherited_Subprograms (S : Entity_Id) return Subprogram_List; + function Inherited_Subprograms + (S : Entity_Id; + No_Interfaces : Boolean := False; + Interfaces_Only : Boolean := False) return Subprogram_List; -- Given the spec of a subprogram, this function gathers any inherited - -- subprograms from direct inheritance or via interfaces. The list is - -- a list of entity id's of the specs of inherited subprograms. Returns - -- a null array if passed an Empty spec id. Note that the returned array + -- subprograms from direct inheritance or via interfaces. The list is a + -- list of entity id's of the specs of inherited subprograms. Returns a + -- null array if passed an Empty spec id. Note that the returned array -- only includes subprograms and generic subprograms (and excludes any - -- other inherited entities, in particular enumeration literals). + -- other inherited entities, in particular enumeration literals). If + -- No_Interfaces is True, only return inherited subprograms not coming + -- from an interface. If Interfaces_Only is True, only return inherited + -- subprograms from interfaces. Otherwise, subprograms inherited directly + -- come first, starting with the closest ancestors, and are followed by + -- subprograms inherited from interfaces. At most one of No_Interfaces + -- and Interfaces_Only should be True. function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an diff --git a/main/gcc/ada/sem_elab.adb b/main/gcc/ada/sem_elab.adb index e8f68e5ab30..e5e29bcce21 100644 --- a/main/gcc/ada/sem_elab.adb +++ b/main/gcc/ada/sem_elab.adb @@ -263,11 +263,15 @@ package body Sem_Elab is function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; -- Determine whether entity Id denotes a [Deep_]Finalize procedure - procedure Output_Calls (N : Node_Id); + procedure Output_Calls + (N : Node_Id; + Check_Elab_Flag : Boolean); -- Outputs chain of calls stored in the Elab_Call table. The caller has -- already generated the main warning message, so the warnings generated -- are all continuation messages. The argument is the call node at which - -- the messages are to be placed. + -- the messages are to be placed. When Check_Elab_Flag is set, calls are + -- enumerated only when flag Elab_Warning is set for the dynamic case or + -- when flag Elab_Info_Messages is set for the static case. function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; -- Given two scopes, determine whether they are the same scope from an @@ -497,6 +501,48 @@ package body Sem_Elab is Generate_Warnings : Boolean := True; In_Init_Proc : Boolean := False) is + Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; + -- Indicates if we have Access attribute case + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id); + -- 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. + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + -- Dynamic elaboration checks, real warning + + if Dynamic_Elaboration_Checks then + if not Access_Case then + if Msg_D /= "" and then Elab_Warnings then + Error_Msg_NE (Msg_D, N, Ent); + end if; + end if; + + -- Static elaboration checks, info message + + else + if Elab_Info_Messages then + Error_Msg_NE (Msg_S, N, Ent); + end if; + end if; + end Elab_Warning; + + -- Local variables + Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; Decl : Node_Id; @@ -525,9 +571,6 @@ package body Sem_Elab is Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; -- Indicates if we have instantiation case - Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference; - -- Indicates if we have Access attribute case - Caller_Unit_Internal : Boolean; Callee_Unit_Internal : Boolean; @@ -544,6 +587,8 @@ package body Sem_Elab is -- warnings on the scope are also suppressed. For the internal case, -- we ignore this flag. + -- Start of processing for Check_A_Call + begin -- If the call is known to be within a local Suppress Elaboration -- pragma, nothing to check. This can happen in task bodies. But @@ -873,101 +918,64 @@ package body Sem_Elab is and then (Elab_Warnings or Elab_Info_Messages) and then Generate_Warnings then - Generate_Elab_Warnings : declare - procedure Elab_Warning - (Msg_D : String; - Msg_S : String; - Ent : Node_Or_Entity_Id); - -- 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. - - ------------------ - -- Elab_Warning -- - ------------------ - - procedure Elab_Warning - (Msg_D : String; - Msg_S : String; - Ent : Node_Or_Entity_Id) - is - begin - -- Dynamic elaboration checks, real warning + -- Instantiation case - if Dynamic_Elaboration_Checks then - if not Access_Case then - if Msg_D /= "" and then Elab_Warnings then - Error_Msg_NE (Msg_D, N, Ent); - end if; - end if; - - -- Static elaboration checks, info message - - else - if Elab_Info_Messages then - Error_Msg_NE (Msg_S, N, Ent); - end if; - end if; - end Elab_Warning; + if Inst_Case then + Elab_Warning + ("instantiation of& may raise Program_Error?l?", + "info: instantiation of& during elaboration?$?", Ent); - -- Start of processing for Generate_Elab_Warnings + -- Indirect call case, info message only in static elaboration + -- case, because the attribute reference itself cannot raise an + -- exception. - begin - -- Instantiation case + elsif Access_Case then + Elab_Warning + ("", "info: access to& during elaboration?$?", Ent); - if Inst_Case then - Elab_Warning - ("instantiation of& may raise Program_Error?l?", - "info: instantiation of& during elaboration?$?", Ent); + -- Subprogram call case - -- Indirect call case, info message only in static elaboration - -- case, because the attribute reference itself cannot raise - -- an exception. - - elsif Access_Case then + else + if Nkind (Name (N)) in N_Has_Entity + and then Is_Init_Proc (Entity (Name (N))) + and then Comes_From_Source (Ent) + then Elab_Warning - ("", "info: access to& during elaboration?$?", Ent); - - -- Subprogram call case + ("implicit call to & may raise Program_Error?l?", + "info: implicit call to & during elaboration?$?", + Ent); else - if Nkind (Name (N)) in N_Has_Entity - and then Is_Init_Proc (Entity (Name (N))) - and then Comes_From_Source (Ent) - then - Elab_Warning - ("implicit call to & may raise Program_Error?l?", - "info: implicit call to & during elaboration?$?", - Ent); - - else - Elab_Warning - ("call to & may raise Program_Error?l?", - "info: call to & during elaboration?$?", - Ent); - end if; + Elab_Warning + ("call to & may raise Program_Error?l?", + "info: call to & during elaboration?$?", + Ent); end if; + end if; - Error_Msg_Qual_Level := Nat'Last; + Error_Msg_Qual_Level := Nat'Last; - if Nkind (N) in N_Subprogram_Instantiation then - Elab_Warning - ("\missing pragma Elaborate for&?l?", - "\implicit pragma Elaborate for& generated?$?", - W_Scope); + if Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?l?", + "\implicit pragma Elaborate for& generated?$?", + W_Scope); - else - Elab_Warning - ("\missing pragma Elaborate_All for&?l?", - "\implicit pragma Elaborate_All for & generated?$?", - W_Scope); - end if; - end Generate_Elab_Warnings; + else + Elab_Warning + ("\missing pragma Elaborate_All for&?l?", + "\implicit pragma Elaborate_All for & generated?$?", + W_Scope); + end if; Error_Msg_Qual_Level := 0; - Output_Calls (N); + + -- Take into account the flags related to elaboration warning + -- messages when enumerating the various calls involved. This + -- ensures the proper pairing of the main warning and the + -- clarification messages generated by Output_Calls. + + Output_Calls (N, Check_Elab_Flag => True); -- Set flag to prevent further warnings for same unit unless in -- All_Errors_Mode. @@ -1210,6 +1218,17 @@ package body Sem_Elab is return; end if; + -- Nothing to do if this is a call to a postcondition, which is always + -- within a subprogram body, even though the current scope may be the + -- enclosing scope of the subprogram. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Chars (Entity (Name (N))) = Name_uPostconditions + then + return; + end if; + -- Here we have a call at elaboration time which must be checked if Debug_Flag_LL then @@ -2245,13 +2264,15 @@ package body Sem_Elab is -- Create object declaration for elaboration entity, and put it -- just in front of the spec of the subprogram or generic unit, - -- in the same scope as this unit. + -- in the same scope as this unit. The subprogram may be over- + -- loaded, so make the name of elaboration entity unique by + -- means of a numeric suffix. declare Loce : constant Source_Ptr := Sloc (E); Ent : constant Entity_Id := Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (E), 'E')); + Chars => New_External_Name (Chars (E), 'E', -1)); begin Set_Elaboration_Entity (E, Ent); @@ -2316,7 +2337,12 @@ package body Sem_Elab is Error_Msg_N ("\Program_Error ] False); end if; end if; @@ -2414,8 +2440,8 @@ package body Sem_Elab is Decl); Error_Msg_N ("\Program_Error [<<", Decl); - elsif - Present (Corresponding_Body (Unit_Declaration_Node (Proc))) + elsif Present + (Corresponding_Body (Unit_Declaration_Node (Proc))) then Append_Elmt (Proc, Intra_Procs); end if; @@ -3053,8 +3079,13 @@ package body Sem_Elab is -- Output_Calls -- ------------------ - procedure Output_Calls (N : Node_Id) is - Ent : Entity_Id; + procedure Output_Calls + (N : Node_Id; + Check_Elab_Flag : Boolean) + is + function Emit (Flag : Boolean) return Boolean; + -- 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 @@ -3062,6 +3093,19 @@ package body Sem_Elab is -- by the error message circuits (i.e. it has a single upper -- case letter at the end). + ---------- + -- Emit -- + ---------- + + function Emit (Flag : Boolean) return Boolean is + begin + if Check_Elab_Flag then + return Flag; + else + return True; + end if; + end Emit; + ----------------------------- -- Is_Printable_Error_Name -- ----------------------------- @@ -3080,6 +3124,10 @@ package body Sem_Elab is end if; end Is_Printable_Error_Name; + -- Local variables + + Ent : Entity_Id; + -- Start of processing for Output_Calls begin @@ -3091,27 +3139,31 @@ package body Sem_Elab is -- Dynamic elaboration model, warnings controlled by -gnatwl if Dynamic_Elaboration_Checks then - if Is_Generic_Unit (Ent) then - 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 - Error_Msg_NE ("\\?l?& called #", N, Ent); - else - Error_Msg_N ("\\?l?called #", N); + if Emit (Elab_Warnings) then + if Is_Generic_Unit (Ent) then + 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 + Error_Msg_NE ("\\?l?& called #", N, Ent); + else + Error_Msg_N ("\\?l?called #", N); + end if; end if; -- Static elaboration model, info messages controlled by -gnatel else - if Is_Generic_Unit (Ent) then - 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 - Error_Msg_NE ("\\?$?& called #", N, Ent); - else - Error_Msg_N ("\\?$?called #", N); + if Emit (Elab_Info_Messages) then + if Is_Generic_Unit (Ent) then + 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 + Error_Msg_NE ("\\?$?& called #", N, Ent); + else + Error_Msg_N ("\\?$?called #", N); + end if; end if; end if; end loop; diff --git a/main/gcc/ada/sem_eval.adb b/main/gcc/ada/sem_eval.adb index 67e43e10424..e49c51c8671 100644 --- a/main/gcc/ada/sem_eval.adb +++ b/main/gcc/ada/sem_eval.adb @@ -123,6 +123,11 @@ package body Sem_Eval is V : Uint; end record; + type Match_Result is (Match, No_Match, Non_Static); + -- Result returned from functions that test for a matching result. If the + -- operands are not OK_Static then Non_Static will be returned. Otherwise + -- Match/No_Match is returned depending on whether the match succeeds. + type CV_Cache_Array is array (CV_Range) of CV_Entry; CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0)); @@ -137,6 +142,37 @@ package body Sem_Eval is -- Local Subprograms -- ----------------------- + function Choice_Matches + (Expr : Node_Id; + Choice : Node_Id) return Match_Result; + -- Determines whether given value Expr matches the given Choice. The Expr + -- can be of 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). The choice can be a range, subtype name, subtype indication, + -- or expression. The returned result is Non_Static if Choice is not + -- OK_Static, otherwise either Match or No_Match is returned depending + -- on whether Choice matches Expr. This is used for case expression + -- alternatives, and also for membership tests. In each case, more + -- possibilities are tested than the syntax allows (e.g. membership allows + -- subtype indications and non-discrete types, and case allows an OTHERS + -- choice), but it does not matter, since we have already done a full + -- semantic and syntax check of the construct, so the extra possibilities + -- just will not arise for correct expressions. + -- + -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g + -- a reference to a type, one of whose bounds raises Constraint_Error, then + -- it also sets the Raises_Constraint_Error flag on the Choice itself. + + function Choices_Match + (Expr : Node_Id; + Choices : List_Id) return Match_Result; + -- This function applies Choice_Matches to each element of Choices. If the + -- result is No_Match, then it continues and checks the next element. If + -- the result is Match or Non_Static, this result is immediately given + -- as the result without checking the rest of the list. Expr can be of + -- 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 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 @@ -144,6 +180,32 @@ 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 Is_OK_Static_Choice (Choice : Node_Id) return Boolean; + -- Given a choice (from a case expression or membership test), returns + -- True if the choice is static and does not raise a Constraint_Error. + + function Is_OK_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_OK_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 + -- equivalent range attribute references already turned them into the + -- equivalent range). This differs from Is_OK_Static_Range (which is what + -- must be used by clients) in that it does not care whether the bounds + -- 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 @@ -165,6 +227,16 @@ package body Sem_Eval is -- this is an illegality if N is static, and should generate a warning -- otherwise. + function Real_Or_String_Static_Predicate_Matches + (Val : Node_Id; + Typ : Entity_Id) return Boolean; + -- This is the function used to evaluate real or string static predicates. + -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which + -- represents the value to be tested against the predicate. Typ is the + -- type with the predicate, from which the predicate expression can be + -- extracted. The result returned is True if the given value satisfies + -- the predicate. + procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id); -- N and Exp are nodes representing an expression, Exp is known to raise -- CE. N is rewritten in term of Exp in the optimal way. @@ -254,6 +326,86 @@ package body Sem_Eval is procedure To_Bits (U : Uint; B : out Bits); -- Converts a Uint value to a bit string of length B'Length + ----------------------------------------------- + -- Check_Expression_Against_Static_Predicate -- + ----------------------------------------------- + + procedure Check_Expression_Against_Static_Predicate + (Expr : Node_Id; + Typ : Entity_Id) + is + begin + -- Nothing to do if expression is not known at compile time, or the + -- type has no static predicate set (will be the case for all non-scalar + -- types, so no need to make a special test for that). + + if not (Has_Static_Predicate (Typ) + and then Compile_Time_Known_Value (Expr)) + then + return; + end if; + + -- 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). + + -- Case of real static predicate + + if Is_Real_Type (Typ) then + if Real_Or_String_Static_Predicate_Matches + (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)), + Typ => Typ) + then + return; + end if; + + -- Case of string static predicate + + elsif Is_String_Type (Typ) then + if Real_Or_String_Static_Predicate_Matches + (Val => Expr_Value_S (Expr), Typ => Typ) + then + return; + end if; + + -- Case of discrete static predicate + + else + pragma Assert (Is_Discrete_Type (Typ)); + + -- If static predicate matches, nothing to do + + if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then + return; + end if; + end if; + + -- Here we know that the predicate will fail + + -- Special case of static expression failing a predicate (other than one + -- that was explicitly specified with a Dynamic_Predicate aspect). This + -- is the case where the expression is no longer considered static. + + if Is_Static_Expression (Expr) + and then not Has_Dynamic_Predicate_Aspect (Typ) + then + Error_Msg_NE + ("??static expression fails static predicate check on &", + Expr, Typ); + Error_Msg_N + ("\??expression is no longer considered static", Expr); + Set_Is_Static_Expression (Expr, False); + + -- In all other cases, this is just a warning that a test will fail. + -- It does not matter if the expression is static or not, or if the + -- predicate comes from a dynamic predicate aspect or not. + + else + Error_Msg_NE + ("??expression fails predicate check on &", Expr, Typ); + end if; + end Check_Expression_Against_Static_Predicate; + ------------------------------ -- Check_Non_Static_Context -- ------------------------------ @@ -421,6 +573,167 @@ package body Sem_Eval is end if; end Check_String_Literal_Length; + -------------------- + -- Choice_Matches -- + -------------------- + + function Choice_Matches + (Expr : Node_Id; + Choice : Node_Id) return Match_Result + is + Etyp : constant Entity_Id := Etype (Expr); + Val : Uint; + ValR : Ureal; + ValS : Node_Id; + + begin + pragma Assert (Compile_Time_Known_Value (Expr)); + pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp)); + + if not Is_OK_Static_Choice (Choice) then + Set_Raises_Constraint_Error (Choice); + return Non_Static; + + -- Discrete type case + + elsif Is_Discrete_Type (Etype (Expr)) then + Val := Expr_Value (Expr); + + if Nkind (Choice) = N_Range then + if Val >= Expr_Value (Low_Bound (Choice)) + and then + Val <= Expr_Value (High_Bound (Choice)) + then + return Match; + else + return No_Match; + end if; + + elsif Nkind (Choice) = N_Subtype_Indication + or else + (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) + then + if Val >= Expr_Value (Type_Low_Bound (Etype (Choice))) + and then + Val <= Expr_Value (Type_High_Bound (Etype (Choice))) + then + return Match; + else + return No_Match; + end if; + + elsif Nkind (Choice) = N_Others_Choice then + return Match; + + else + if Val = Expr_Value (Choice) then + return Match; + else + return No_Match; + end if; + end if; + + -- Real type case + + elsif Is_Real_Type (Etype (Expr)) then + ValR := Expr_Value_R (Expr); + + if Nkind (Choice) = N_Range then + if ValR >= Expr_Value_R (Low_Bound (Choice)) + and then + ValR <= Expr_Value_R (High_Bound (Choice)) + then + return Match; + else + return No_Match; + end if; + + elsif Nkind (Choice) = N_Subtype_Indication + 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 + ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice))) + then + return Match; + else + return No_Match; + end if; + + else + if ValR = Expr_Value_R (Choice) then + return Match; + else + return No_Match; + end if; + end if; + + -- String type cases + + else + pragma Assert (Is_String_Type (Etype (Expr))); + ValS := Expr_Value_S (Expr); + + if Nkind (Choice) = N_Subtype_Indication + or else + (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) + then + if not Is_Constrained (Etype (Choice)) then + return Match; + + else + declare + Typlen : constant Uint := + String_Type_Len (Etype (Choice)); + Strlen : constant Uint := + UI_From_Int (String_Length (Strval (ValS))); + begin + if Typlen = Strlen then + return Match; + else + return No_Match; + end if; + end; + end if; + + else + if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice))) + then + return Match; + else + return No_Match; + end if; + end if; + end if; + end Choice_Matches; + + ------------------- + -- Choices_Match -- + ------------------- + + function Choices_Match + (Expr : Node_Id; + Choices : List_Id) return Match_Result + is + Choice : Node_Id; + Result : Match_Result; + + begin + Choice := First (Choices); + while Present (Choice) loop + Result := Choice_Matches (Expr, Choice); + + if Result /= No_Match then + return Result; + end if; + + Next (Choice); + end loop; + + return No_Match; + end Choices_Match; + -------------------------- -- Compile_Time_Compare -- -------------------------- @@ -747,9 +1060,9 @@ package body Sem_Eval is -- conditions when this is inappropriate. if not (Full_Analysis - or else (Is_Static_Expression (L) + or else (Is_OK_Static_Expression (L) and then - Is_Static_Expression (R))) + Is_OK_Static_Expression (R))) then return Unknown; end if; @@ -927,16 +1240,22 @@ package body Sem_Eval is return Unknown; end if; - -- Replace types by base types for the case of entities which are not + -- Replace types by base types for the case of values which are not -- known to have valid representations. This takes care of properly -- dealing with invalid representations. - if not Assume_Valid and then not Assume_No_Invalid_Values then - if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then + if not Assume_Valid then + if not (Is_Entity_Name (L) + and then (Is_Known_Valid (Entity (L)) + or else Assume_No_Invalid_Values)) + then Ltyp := Underlying_Type (Base_Type (Ltyp)); end if; - if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then + if not (Is_Entity_Name (R) + and then (Is_Known_Valid (Entity (R)) + or else Assume_No_Invalid_Values)) + then Rtyp := Underlying_Type (Base_Type (Rtyp)); end if; end if; @@ -1349,13 +1668,6 @@ package body Sem_Eval is N_Null) then return True; - - -- Any reference to Null_Parameter is known at compile time. No - -- other attribute references (that have not already been folded) - -- are known at compile time. - - elsif K = N_Attribute_Reference then - return Attribute_Name (Op) = Name_Null_Parameter; end if; end if; @@ -1565,8 +1877,11 @@ package body Sem_Eval is Apply_Compile_Time_Constraint_Error (N, "division by zero", CE_Divide_By_Zero, Warn => not Stat); + Set_Raises_Constraint_Error (N); return; + -- Otherwise we can do the division + else Result := Left_Int / Right_Int; end if; @@ -1744,60 +2059,101 @@ package body Sem_Eval is -------------------------- -- A conditional expression is static if all its conditions and dependent - -- expressions are static. + -- expressions are static. Note that we do not care if the dependent + -- expressions raise CE, except for the one that will be selected. procedure Eval_Case_Expression (N : Node_Id) is - Alt : Node_Id; - Choice : Node_Id; - Is_Static : Boolean; - Result : Node_Id; - Val : Uint; + Alt : Node_Id; + Choice : Node_Id; begin - Result := Empty; - Is_Static := True; + Set_Is_Static_Expression (N, False); - if Is_Static_Expression (Expression (N)) then - Val := Expr_Value (Expression (N)); - else + if not Is_Static_Expression (Expression (N)) then Check_Non_Static_Context (Expression (N)); - Is_Static := False; + return; end if; + -- First loop, make sure all the alternatives are static expressions + -- none of which raise Constraint_Error. We make the constraint error + -- check because part of the legality condition for a correct static + -- case expression is that the cases are covered, like any other case + -- expression. And we can't do that if any of the conditions raise an + -- exception, so we don't even try to evaluate if that is the case. + Alt := First (Alternatives (N)); + while Present (Alt) loop - Search : while Present (Alt) loop - if not Is_Static - or else not Is_Static_Expression (Expression (Alt)) - then - Check_Non_Static_Context (Expression (Alt)); - Is_Static := False; + -- The expression must be static, but we don't care at this stage + -- if it raises Constraint_Error (the alternative might not match, + -- in which case the expression is statically unevaluated anyway). - else - Choice := First (Discrete_Choices (Alt)); - while Present (Choice) loop - if Nkind (Choice) = N_Others_Choice then - Result := Expression (Alt); - exit Search; + if not Is_Static_Expression (Expression (Alt)) then + Check_Non_Static_Context (Expression (Alt)); + return; + end if; - elsif Expr_Value (Choice) = Val then - Result := Expression (Alt); - exit Search; + -- The choices of a case always have to be static, and cannot raise + -- an exception. If this condition is not met, then the expression + -- is plain illegal, so just abandon evaluation attempts. No need + -- to check non-static context when we have something illegal anyway. - else - Next (Choice); - end if; - end loop; + if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then + return; end if; Next (Alt); - end loop Search; + end loop; - if Is_Static then - Rewrite (N, Relocate_Node (Result)); + -- OK, if the above loop gets through it means that all choices are OK + -- static (don't raise exceptions), so the whole case is static, and we + -- can find the matching alternative. + + Set_Is_Static_Expression (N); + + -- Now to deal with propagating a possible constraint error + + -- If the selecting expression raises CE, propagate and we are done + + if Raises_Constraint_Error (Expression (N)) then + Set_Raises_Constraint_Error (N); + + -- Otherwise we need to check the alternatives to find the matching + -- one. CE's in other than the matching one are not relevant. But we + -- do need to check the matching one. Unlike the first loop, we do not + -- have to go all the way through, when we find the matching one, quit. else - Set_Is_Static_Expression (N, False); + Alt := First (Alternatives (N)); + Search : loop + + -- We must find a match among the alternatives. If not, this must + -- be due to other errors, so just ignore, leaving as non-static. + + if No (Alt) then + Set_Is_Static_Expression (N, False); + return; + end if; + + -- Otherwise loop through choices of this alternative + + Choice := First (Discrete_Choices (Alt)); + while Present (Choice) loop + + -- If we find a matching choice, then the Expression of this + -- alternative replaces N (Raises_Constraint_Error flag is + -- included, so we don't have to special case that). + + if Choice_Matches (Expression (N), Choice) = Match then + Rewrite (N, Relocate_Node (Expression (Alt))); + return; + end if; + + Next (Choice); + end loop; + + Next (Alt); + end loop Search; end if; end Eval_Case_Expression; @@ -2001,8 +2357,17 @@ package body Sem_Eval is Is_Static_Expression (Then_Expr) and then Is_Static_Expression (Else_Expr); + -- True if result is static begin + -- If result not static, nothing to do, otherwise set static result + + if not Rstat then + return; + else + Set_Is_Static_Expression (N); + end if; + -- If any operand is Any_Type, just propagate to result and do not try -- to fold, this prevents cascaded errors. @@ -2013,6 +2378,15 @@ package body Sem_Eval is Set_Etype (N, Any_Type); Set_Is_Static_Expression (N, False); return; + end if; + + -- If condition raises constraint error then we have already signaled + -- an error, and we just propagate to the result and do not fold. + + if Raises_Constraint_Error (Condition) then + Set_Raises_Constraint_Error (N); + return; + end if; -- Static case where we can fold. Note that we don't try to fold cases -- where the condition is known at compile time, but the result is @@ -2020,43 +2394,31 @@ package body Sem_Eval is -- the expander puts in a redundant test and we remove it. Instead we -- deal with these cases in the expander. - elsif Rstat then - - -- Select result operand - - if Is_True (Expr_Value (Condition)) then - Result := Then_Expr; - Non_Result := Else_Expr; - else - Result := Else_Expr; - Non_Result := Then_Expr; - end if; + -- Select result operand - -- Note that it does not matter if the non-result operand raises a - -- Constraint_Error, but if the result raises constraint error then - -- we replace the node with a raise constraint error. This will - -- properly propagate Raises_Constraint_Error since this flag is - -- set in Result. - - if Raises_Constraint_Error (Result) then - Rewrite_In_Raise_CE (N, Result); - Check_Non_Static_Context (Non_Result); + if Is_True (Expr_Value (Condition)) then + Result := Then_Expr; + Non_Result := Else_Expr; + else + Result := Else_Expr; + Non_Result := Then_Expr; + end if; - -- Otherwise the result operand replaces the original node + -- Note that it does not matter if the non-result operand raises a + -- Constraint_Error, but if the result raises constraint error then we + -- replace the node with a raise constraint error. This will properly + -- propagate Raises_Constraint_Error since this flag is set in Result. - else - Rewrite (N, Relocate_Node (Result)); - end if; + if Raises_Constraint_Error (Result) then + Rewrite_In_Raise_CE (N, Result); + Check_Non_Static_Context (Non_Result); - -- Case of condition not known at compile time + -- Otherwise the result operand replaces the original node else - Check_Non_Static_Context (Condition); - Check_Non_Static_Context (Then_Expr); - Check_Non_Static_Context (Else_Expr); + Rewrite (N, Relocate_Node (Result)); + Set_Is_Static_Expression (N); end if; - - Set_Is_Static_Expression (N, Rstat); end Eval_If_Expression; ---------------------------- @@ -2288,11 +2650,7 @@ package body Sem_Eval is Right_Int : constant Uint := Expr_Value (Right); begin - -- VMS includes bitwise operations on signed types - - if Is_Modular_Integer_Type (Etype (N)) - or else Is_VMS_Operator (Entity (N)) - then + if Is_Modular_Integer_Type (Etype (N)) then declare Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); @@ -2356,132 +2714,78 @@ package body Sem_Eval is procedure Eval_Membership_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); - Def_Id : Entity_Id; - Lo : Node_Id; - Hi : Node_Id; - Result : Boolean; - Stat : Boolean; - Fold : Boolean; + Alts : constant List_Id := Alternatives (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 Etype (Right) = Any_Type then + if Etype (Left) = Any_Type + or else (Present (Right) and then Etype (Right) = 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 (Predicate_Function (Etype (Right))) + or else (Present (Right) + and then Present (Predicate_Function (Etype (Right)))) then return; end if; - -- Case of right operand is a subtype name - - if Is_Entity_Name (Right) then - Def_Id := Entity (Right); - - if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id)) - and then Is_OK_Static_Subtype (Def_Id) - then - Test_Expression_Is_Foldable (N, Left, Stat, Fold); + -- If left operand non-static, then nothing to do - if not Fold or else not Stat then - return; - end if; - else - Check_Non_Static_Context (Left); - return; - end if; + if not Is_Static_Expression (Left) then + return; + end if; - -- For string membership tests we will check the length further on + -- If choice is non-static, left operand is in non-static context - if not Is_String_Type (Def_Id) then - Lo := Type_Low_Bound (Def_Id); - Hi := Type_High_Bound (Def_Id); - else - Lo := Empty; - Hi := Empty; - end if; + if (Present (Right) and then not Is_Static_Choice (Right)) + or else (Present (Alts) and then not Is_Static_Choice_List (Alts)) + then + Check_Non_Static_Context (Left); + return; + end if; - -- Case of right operand is a range + -- Otherwise we definitely have a static expression - else - if Is_Static_Range (Right) then - Test_Expression_Is_Foldable (N, Left, Stat, Fold); + Set_Is_Static_Expression (N); - if not Fold or else not Stat then - return; + -- If left operand raises constraint error, propagate and we are done - -- If one bound of range raises CE, then don't try to fold + if Raises_Constraint_Error (Left) then + Set_Raises_Constraint_Error (N, True); - elsif not Is_OK_Static_Range (Right) then - Check_Non_Static_Context (Left); - return; - end if; + -- See if we match + else + if Present (Right) then + Result := Choice_Matches (Left, Right); else - Check_Non_Static_Context (Left); - return; + Result := Choices_Match (Left, Alts); end if; - -- Here we know range is an OK static range - - Lo := Low_Bound (Right); - Hi := High_Bound (Right); - end if; + -- If result is Non_Static, it means that we raise Constraint_Error, + -- since we already tested that the operands were themselves static. - -- For strings we check that the length of the string expression is - -- compatible with the string subtype if the subtype is constrained, - -- or if unconstrained then the test is always true. + if Result = Non_Static then + Set_Raises_Constraint_Error (N); - if Is_String_Type (Etype (Right)) then - if not Is_Constrained (Etype (Right)) then - Result := True; + -- Otherwise we have our result (flipped if NOT IN case) else - declare - Typlen : constant Uint := String_Type_Len (Etype (Right)); - Strlen : constant Uint := - UI_From_Int - (String_Length (Strval (Get_String_Val (Left)))); - begin - Result := (Typlen = Strlen); - end; + Fold_Uint + (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True); + Warn_On_Known_Condition (N); end if; - - -- Fold the membership test. We know we have a static range and Lo and - -- Hi are set to the expressions for the end points of this range. - - elsif Is_Real_Type (Etype (Right)) then - declare - Leftval : constant Ureal := Expr_Value_R (Left); - begin - Result := Expr_Value_R (Lo) <= Leftval - and then Leftval <= Expr_Value_R (Hi); - end; - - else - declare - Leftval : constant Uint := Expr_Value (Left); - begin - Result := Expr_Value (Lo) <= Leftval - and then Leftval <= Expr_Value (Hi); - end; - end if; - - if Nkind (N) = N_Not_In then - Result := not Result; end if; - - Fold_Uint (N, Test (Result), True); - - Warn_On_Known_Condition (N); end Eval_Membership_Op; ------------------------ @@ -2765,6 +3069,10 @@ package body Sem_Eval is -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings, -- the result is never static, even if the operands are. + -- However, for internally generated nodes, we allow string equality and + -- inequality to be static. This is because we rewrite A in "ABC" as an + -- equality test A = "ABC", and the former is definitely static. + procedure Eval_Relational_Op (N : Node_Id) is Left : constant Node_Id := Left_Opnd (N); Right : constant Node_Id := Right_Opnd (N); @@ -3002,9 +3310,16 @@ package body Sem_Eval is -- Only comparisons of scalars can give static results. In -- particular, comparisons of strings never yield a static - -- result, even if both operands are static strings. + -- result, even if both operands are static strings, except that + -- as noted above, we allow equality/inequality for strings. + + if Is_String_Type (Typ) + and then not Comes_From_Source (N) + and then Nkind_In (N, N_Op_Eq, N_Op_Ne) + then + null; - if not Is_Scalar_Type (Typ) then + elsif not Is_Scalar_Type (Typ) then Is_Static_Expression := False; Set_Is_Static_Expression (N, False); end if; @@ -3020,9 +3335,8 @@ package body Sem_Eval is Otype := Find_Universal_Operator_Type (N); end if; - -- For static real type expressions, we cannot use - -- Compile_Time_Compare since it worries about run-time - -- results which are not exact. + -- For static real type expressions, do not use Compile_Time_Compare + -- since it worries about run-time results which are not exact. if Is_Static_Expression and then Is_Real_Type (Typ) then declare @@ -3297,53 +3611,6 @@ package body Sem_Eval is end if; end Eval_Slice; - --------------------------------- - -- Eval_Static_Predicate_Check -- - --------------------------------- - - function Eval_Static_Predicate_Check - (N : Node_Id; - Typ : Entity_Id) return Boolean - is - Loc : constant Source_Ptr := Sloc (N); - - begin - -- Discrete type case - - if Is_Discrete_Type (Typ) then - declare - Pred : constant List_Id := Static_Predicate (Typ); - Test : Node_Id; - - begin - pragma Assert (Present (Pred)); - - -- The static predicate is a list of alternatives in the proper - -- format for an Ada 2012 membership test. If the argument is a - -- literal, the membership test can be evaluated statically. This - -- is easier than running a full intepretation of the predicate - -- expression, and more efficient in some cases. - - Test := - Make_In (Loc, - Left_Opnd => New_Copy_Tree (N), - Right_Opnd => Empty, - Alternatives => Pred); - Analyze_And_Resolve (Test, Standard_Boolean); - - return Nkind (Test) = N_Identifier - and then Entity (Test) = Standard_True; - end; - - -- Real type case - - else - pragma Assert (Is_Real_Type (Typ)); - Error_Msg_N ("??real predicate not applied", N); - return True; - end if; - end Eval_Static_Predicate_Check; - ------------------------- -- Eval_String_Literal -- ------------------------- @@ -3394,16 +3661,11 @@ package body Sem_Eval is -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 -- if its bounds are outside the index base type and this index type is -- static. This can happen in only two ways. Either the string literal - -- is too long, or it is null, and the lower bound is type'First. In - -- either case it is the upper bound that is out of range of the index - -- type. + -- is too long, or it is null, and the lower bound is type'First. Either + -- way it is the upper bound that is out of range of the index type. + if Ada_Version >= Ada_95 then - if Root_Type (Bas) = Standard_String - or else - Root_Type (Bas) = Standard_Wide_String - or else - Root_Type (Bas) = Standard_Wide_Wide_String - then + if Is_Standard_String_Type (Bas) then Xtp := Standard_Positive; else Xtp := Etype (First_Index (Bas)); @@ -3757,13 +4019,6 @@ package body Sem_Eval is pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); return Corresponding_Integer_Value (N); - -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero - - elsif Kind = N_Attribute_Reference - and then Attribute_Name (N) = Name_Null_Parameter - then - return Uint_0; - -- Otherwise must be character literal else @@ -3836,13 +4091,6 @@ package body Sem_Eval is pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); Val := Corresponding_Integer_Value (N); - -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero - - elsif Kind = N_Attribute_Reference - and then Attribute_Name (N) = Name_Null_Parameter - then - Val := Uint_0; - -- Otherwise must be character literal else @@ -3904,18 +4152,12 @@ package body Sem_Eval is elsif Kind = N_Integer_Literal then return UR_From_Uint (Expr_Value (N)); - -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0 + -- Here, we have a node that cannot be interpreted as a compile time + -- constant. That is definitely an error. - elsif Kind = N_Attribute_Reference - and then Attribute_Name (N) = Name_Null_Parameter - then - return Ureal_0; + else + raise Program_Error; end if; - - -- If we fall through, we have a node that cannot be interpreted as a - -- compile time constant. That is definitely an error. - - raise Program_Error; end Expr_Value_R; ------------------ @@ -4092,6 +4334,11 @@ package body Sem_Eval is Typ : constant Entity_Id := Etype (N); begin + if Raises_Constraint_Error (N) then + Set_Is_Static_Expression (N, Static); + return; + end if; + Rewrite (N, Make_String_Literal (Loc, Strval => Val)); -- We now have the literal with the right value, both the actual type @@ -4120,6 +4367,11 @@ package body Sem_Eval is Ent : Entity_Id; begin + if Raises_Constraint_Error (N) then + Set_Is_Static_Expression (N, Static); + return; + end if; + -- If we are folding a named number, retain the entity in the literal, -- for ASIS use. @@ -4177,6 +4429,11 @@ package body Sem_Eval is Ent : Entity_Id; begin + if Raises_Constraint_Error (N) then + Set_Is_Static_Expression (N, Static); + return; + end if; + -- If we are folding a named number, retain the entity in the literal, -- for ASIS use. @@ -4400,6 +4657,60 @@ package body Sem_Eval is end if; end Is_Null_Range; + ------------------------- + -- Is_OK_Static_Choice -- + ------------------------- + + function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is + begin + -- Check various possibilities for choice + + -- Note: for membership tests, we test more cases than are possible + -- (in particular subtype indication), but it doesn't matter because + -- it just won't occur (we have already done a syntax check). + + if Nkind (Choice) = N_Others_Choice then + return True; + + elsif Nkind (Choice) = N_Range then + return Is_OK_Static_Range (Choice); + + elsif Nkind (Choice) = N_Subtype_Indication + or else + (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) + then + return Is_OK_Static_Subtype (Etype (Choice)); + + else + return Is_OK_Static_Expression (Choice); + end if; + end Is_OK_Static_Choice; + + ------------------------------ + -- Is_OK_Static_Choice_List -- + ------------------------------ + + function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is + Choice : Node_Id; + + begin + if not Is_Static_Choice_List (Choices) then + return False; + end if; + + Choice := First (Choices); + while Present (Choice) loop + if not Is_OK_Static_Choice (Choice) then + Set_Raises_Constraint_Error (Choice); + return False; + end if; + + Next (Choice); + end loop; + + return True; + end Is_OK_Static_Choice_List; + ----------------------------- -- Is_OK_Static_Expression -- ----------------------------- @@ -4502,7 +4813,56 @@ package body Sem_Eval is Out_Of_Range; end Is_Out_Of_Range; - --------------------- + ---------------------- + -- Is_Static_Choice -- + ---------------------- + + function Is_Static_Choice (Choice : Node_Id) return Boolean is + begin + -- Check various possibilities for choice + + -- Note: for membership tests, we test more cases than are possible + -- (in particular subtype indication), but it doesn't matter because + -- it just won't occur (we have already done a syntax check). + + if Nkind (Choice) = N_Others_Choice then + return True; + + elsif Nkind (Choice) = N_Range then + return Is_Static_Range (Choice); + + elsif Nkind (Choice) = N_Subtype_Indication + or else + (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) + then + return Is_Static_Subtype (Etype (Choice)); + + else + return Is_Static_Expression (Choice); + end if; + end Is_Static_Choice; + + --------------------------- + -- Is_Static_Choice_List -- + --------------------------- + + function Is_Static_Choice_List (Choices : List_Id) return Boolean is + Choice : Node_Id; + + begin + Choice := First (Choices); + while Present (Choice) loop + if not Is_Static_Choice (Choice) then + return False; + end if; + + Next (Choice); + end loop; + + return True; + end Is_Static_Choice_List; + +--------------------- -- Is_Static_Range -- --------------------- @@ -4513,7 +4873,7 @@ package body Sem_Eval is function Is_Static_Range (N : Node_Id) return Boolean is begin - return Is_Static_Expression (Low_Bound (N)) + return Is_Static_Expression (Low_Bound (N)) and then Is_Static_Expression (High_Bound (N)); end Is_Static_Range; @@ -4575,6 +4935,272 @@ package body Sem_Eval is end if; end Is_Static_Subtype; + ------------------------------- + -- Is_Statically_Unevaluated -- + ------------------------------- + + function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is + function Check_Case_Expr_Alternative + (CEA : Node_Id) return Match_Result; + -- We have a message emanating from the Expression of a case expression + -- alternative. We examine this alternative, as follows: + -- + -- If the selecting expression of the parent case is non-static, or + -- if any of the discrete choices of the given case alternative are + -- non-static or raise Constraint_Error, return Non_Static. + -- + -- Otherwise check if the selecting expression matches any of the given + -- discrete choices. If so, the alternative is executed and we return + -- Match, otherwise, the alternative can never be executed, and so we + -- return No_Match. + + --------------------------------- + -- Check_Case_Expr_Alternative -- + --------------------------------- + + function Check_Case_Expr_Alternative + (CEA : Node_Id) return Match_Result + is + Case_Exp : constant Node_Id := Parent (CEA); + Choice : Node_Id; + Prev_CEA : Node_Id; + + begin + pragma Assert (Nkind (Case_Exp) = N_Case_Expression); + + -- Check that selecting expression is static + + if not Is_OK_Static_Expression (Expression (Case_Exp)) then + return Non_Static; + end if; + + if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then + return Non_Static; + end if; + + -- All choices are now known to be static. Now see if alternative + -- matches one of the choices. + + Choice := First (Discrete_Choices (CEA)); + while Present (Choice) loop + + -- Check various possibilities for choice, returning Match if we + -- find the selecting value matches any of the choices. Note that + -- we know we are the last choice, so we don't have to keep going. + + if Nkind (Choice) = N_Others_Choice then + + -- Others choice is a bit annoying, it matches if none of the + -- previous alternatives matches (note that we know we are the + -- last alternative in this case, so we can just go backwards + -- from us to see if any previous one matches). + + Prev_CEA := Prev (CEA); + while Present (Prev_CEA) loop + if Check_Case_Expr_Alternative (Prev_CEA) = Match then + return No_Match; + end if; + + Prev (Prev_CEA); + end loop; + + return Match; + + -- Else we have a normal static choice + + elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then + return Match; + end if; + + -- If we fall through, it means that the discrete choice did not + -- match the selecting expression, so continue. + + Next (Choice); + end loop; + + -- If we get through that loop then all choices were static, and none + -- of them matched the selecting expression. So return No_Match. + + return No_Match; + end Check_Case_Expr_Alternative; + + -- Local variables + + P : Node_Id; + OldP : Node_Id; + Choice : Node_Id; + + -- Start of processing for Is_Statically_Unevaluated + + begin + -- The (32.x) references here are from RM section 4.9 + + -- (32.1) An expression is statically unevaluated if it is part of ... + + -- This means we have to climb the tree looking for one of the cases + + P := Expr; + loop + OldP := P; + P := Parent (P); + + -- (32.2) The right operand of a static short-circuit control form + -- whose value is determined by its left operand. + + -- AND THEN with False as left operand + + if Nkind (P) = N_And_Then + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_False (Expr_Value (Left_Opnd (P))) + then + return True; + + -- OR ELSE with True as left operand + + elsif Nkind (P) = N_Or_Else + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_True (Expr_Value (Left_Opnd (P))) + then + return True; + + -- (32.3) A dependent_expression of an if_expression whose associated + -- condition is static and equals False. + + elsif Nkind (P) = N_If_Expression then + declare + Cond : constant Node_Id := First (Expressions (P)); + Texp : constant Node_Id := Next (Cond); + Fexp : constant Node_Id := Next (Texp); + + begin + if Compile_Time_Known_Value (Cond) then + + -- Condition is True and we are in the right operand + + if Is_True (Expr_Value (Cond)) and then OldP = Fexp then + return True; + + -- Condition is False and we are in the left operand + + elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then + return True; + end if; + end if; + end; + + -- (32.4) A condition or dependent_expression of an if_expression + -- where the condition corresponding to at least one preceding + -- dependent_expression of the if_expression is static and equals + -- True. + + -- This refers to cases like + + -- (if True then 1 elsif 1/0=2 then 2 else 3) + + -- But we expand elsif's out anyway, so the above looks like: + + -- (if True then 1 else (if 1/0=2 then 2 else 3)) + + -- So for us this is caught by the above check for the 32.3 case. + + -- (32.5) A dependent_expression of a case_expression whose + -- selecting_expression is static and whose value is not covered + -- by the corresponding discrete_choice_list. + + elsif Nkind (P) = N_Case_Expression_Alternative then + + -- First, we have to be in the expression to suppress messages. + -- If we are within one of the choices, we want the message. + + if OldP = Expression (P) then + + -- Statically unevaluated if alternative does not match + + if Check_Case_Expr_Alternative (P) = No_Match then + return True; + end if; + end if; + + -- (32.6) A choice_expression (or a simple_expression of a range + -- that occurs as a membership_choice of a membership_choice_list) + -- of a static membership test that is preceded in the enclosing + -- membership_choice_list by another item whose individual + -- membership test (see (RM 4.5.2)) statically yields True. + + elsif Nkind (P) in N_Membership_Test then + + -- Only possibly unevaluated if simple expression is static + + if not Is_OK_Static_Expression (Left_Opnd (P)) then + null; + + -- All members of the choice list must be static + + elsif (Present (Right_Opnd (P)) + and then not Is_OK_Static_Choice (Right_Opnd (P))) + or else (Present (Alternatives (P)) + and then + not Is_OK_Static_Choice_List (Alternatives (P))) + then + null; + + -- If expression is the one and only alternative, then it is + -- definitely not statically unevaluated, so we only have to + -- test the case where there are alternatives present. + + elsif Present (Alternatives (P)) then + + -- Look for previous matching Choice + + Choice := First (Alternatives (P)); + while Present (Choice) loop + + -- If we reached us and no previous choices matched, this + -- is not the case where we are statically unevaluated. + + exit when OldP = Choice; + + -- If a previous choice matches, then that is the case where + -- we know our choice is statically unevaluated. + + if Choice_Matches (Left_Opnd (P), Choice) = Match then + return True; + end if; + + Next (Choice); + end loop; + + -- If we fall through the loop, we were not one of the choices, + -- we must have been the expression, so that is not covered by + -- this rule, and we keep going. + + null; + end if; + end if; + + -- OK, not statically unevaluated at this level, see if we should + -- keep climbing to look for a higher level reason. + + -- Special case for component association in aggregates, where + -- we want to keep climbing up to the parent aggregate. + + if Nkind (P) = N_Component_Association + and then Nkind (Parent (P)) = N_Aggregate + then + null; + + -- All done if not still within subexpression + + else + exit when Nkind (P) not in N_Subexpr; + end if; + end loop; + + -- If we fall through the loop, not one of the cases covered! + + return False; + end Is_Statically_Unevaluated; + -------------------- -- Not_Null_Range -- -------------------- @@ -4624,15 +5250,22 @@ package body Sem_Eval is -- If we have the static expression case, then this is an illegality -- in Ada 95 mode, except that in an instance, we never generate an -- error (if the error is legitimate, it was already diagnosed in the - -- template). The expression to compute the length of a packed array is - -- attached to the array type itself, and deserves a separate message. + -- template). if Is_Static_Expression (N) and then not In_Instance and then not In_Inlined_Body and then Ada_Version >= Ada_95 then - if Nkind (Parent (N)) = N_Defining_Identifier + -- No message if we are statically unevaluated + + if Is_Statically_Unevaluated (N) then + null; + + -- The expression to compute the length of a packed array is attached + -- to the array type itself, and deserves a separate message. + + elsif Nkind (Parent (N)) = N_Defining_Identifier and then Is_Array_Type (Parent (N)) and then Present (Packed_Array_Impl_Type (Parent (N))) and then Present (First_Rep_Item (Parent (N))) @@ -4642,6 +5275,8 @@ package body Sem_Eval is First_Rep_Item (Parent (N))); Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1)); + -- All cases except the special array case + else Apply_Compile_Time_Constraint_Error (N, "value not in range of}", CE_Range_Check_Failed); @@ -4698,30 +5333,134 @@ package body Sem_Eval is end if; end Predicates_Match; + --------------------------------------------- + -- Real_Or_String_Static_Predicate_Matches -- + --------------------------------------------- + + function Real_Or_String_Static_Predicate_Matches + (Val : Node_Id; + Typ : Entity_Id) return Boolean + is + Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ); + -- The predicate expression from the type + + Pfun : constant Entity_Id := Predicate_Function (Typ); + -- The entity for the predicate function + + Ent_Name : constant Name_Id := Chars (First_Formal (Pfun)); + -- The name of the formal of the predicate function. Occurrences of the + -- type name in Expr have been rewritten as references to this formal, + -- and it has a unique name, so we can identify references by this name. + + Copy : Node_Id; + -- Copy of the predicate function tree + + function Process (N : Node_Id) return Traverse_Result; + -- Function used to process nodes during the traversal in which we will + -- find occurrences of the entity name, and replace such occurrences + -- by a real literal with the value to be tested. + + procedure Traverse is new Traverse_Proc (Process); + -- The actual traversal procedure + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then + declare + Nod : constant Node_Id := New_Copy (Val); + begin + Set_Sloc (Nod, Sloc (N)); + Rewrite (N, Nod); + return Skip; + end; + + else + return OK; + end if; + end Process; + + -- Start of processing for Real_Or_String_Static_Predicate_Matches + + begin + -- First deal with special case of inherited predicate, where the + -- predicate expression looks like: + + -- Expr and then xxPredicate (typ (Ent)) + + -- where Expr is the predicate expression for this level, and the + -- right operand is the call to evaluate the inherited predicate. + + if Nkind (Expr) = N_And_Then + and then Nkind (Right_Opnd (Expr)) = N_Function_Call + then + -- OK we have the inherited case, so make a call to evaluate the + -- inherited predicate. If that fails, so do we! + + if not + Real_Or_String_Static_Predicate_Matches + (Val => Val, + Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr)))))) + then + return False; + end if; + + -- Use the left operand for the continued processing + + Copy := Copy_Separate_Tree (Left_Opnd (Expr)); + + -- Case where call to predicate function appears on its own + + elsif Nkind (Expr) = N_Function_Call then + + -- Here the result is just the result of calling the inner predicate + + return + Real_Or_String_Static_Predicate_Matches + (Val => Val, + Typ => Etype (First_Formal (Entity (Name (Expr))))); + + -- If no inherited predicate, copy whole expression + + else + Copy := Copy_Separate_Tree (Expr); + end if; + + -- Now we replace occurrences of the entity by the value + + Traverse (Copy); + + -- And analyze the resulting static expression to see if it is True + + Analyze_And_Resolve (Copy, Standard_Boolean); + return Is_True (Expr_Value (Copy)); + end Real_Or_String_Static_Predicate_Matches; + ------------------------- -- Rewrite_In_Raise_CE -- ------------------------- procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is - Typ : constant Entity_Id := Etype (N); + Typ : constant Entity_Id := Etype (N); + Stat : constant Boolean := Is_Static_Expression (N); begin - -- If we want to raise CE in the condition of a N_Raise_CE node - -- we may as well get rid of the condition. + -- If we want to raise CE in the condition of a N_Raise_CE node, we + -- can just clear the condition if the reason is appropriate. We do + -- not do this operation if the parent has a reason other than range + -- check failed, because otherwise we would change the reason. if Present (Parent (N)) and then Nkind (Parent (N)) = N_Raise_Constraint_Error + and then Reason (Parent (N)) = + UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed)) then Set_Condition (Parent (N), Empty); - -- If the expression raising CE is a N_Raise_CE node, we can use that - -- one. We just preserve the type of the context. - - elsif Nkind (Exp) = N_Raise_Constraint_Error then - Rewrite (N, Exp); - Set_Etype (N, Typ); - - -- Else build an explcit N_Raise_CE + -- Else build an explicit N_Raise_CE else Rewrite (N, @@ -4730,6 +5469,11 @@ package body Sem_Eval is Set_Raises_Constraint_Error (N); Set_Etype (N, Typ); end if; + + -- Set proper flags in result + + Set_Raises_Constraint_Error (N, True); + Set_Is_Static_Expression (N, Stat); end Rewrite_In_Raise_CE; --------------------- @@ -4772,9 +5516,9 @@ package body Sem_Eval is -- If either subtype is nonstatic then they're not compatible - elsif not Is_Static_Subtype (T1) + elsif not Is_OK_Static_Subtype (T1) or else - not Is_Static_Subtype (T2) + not Is_OK_Static_Subtype (T2) then return False; @@ -4952,8 +5696,8 @@ package body Sem_Eval is -- Otherwise bounds must be static and identical value else - if not Is_Static_Subtype (T1) - or else not Is_Static_Subtype (T2) + if not Is_OK_Static_Subtype (T1) + or else not Is_OK_Static_Subtype (T2) then return False; @@ -5041,8 +5785,8 @@ package body Sem_Eval is Expr2 : constant Node_Id := Node (DA2); begin - if not Is_Static_Expression (Expr1) - or else not Is_Static_Expression (Expr2) + if not Is_OK_Static_Expression (Expr1) + or else not Is_OK_Static_Expression (Expr2) then return False; @@ -5330,9 +6074,24 @@ package body Sem_Eval is -- to get the information in the variable case as well. begin + -- If an error was posted on expression, then return Unknown, we do not + -- want cascaded errors based on some false analysis of a junk node. + + if Error_Posted (N) then + return Unknown; + + -- Expression that raises constraint error is an odd case. We certainly + -- do not want to consider it to be in range. It might make sense to + -- consider it always out of range, but this causes incorrect error + -- messages about static expressions out of range. So we just return + -- Unknown, which is always safe. + + elsif Raises_Constraint_Error (N) then + return Unknown; + -- Universal types have no range limits, so always in range - if Typ = Universal_Integer or else Typ = Universal_Real then + elsif Typ = Universal_Integer or else Typ = Universal_Real then return In_Range; -- Never known if not scalar type. Don't know if this can actually @@ -5350,14 +6109,10 @@ package body Sem_Eval is elsif Is_Generic_Type (Typ) then return Unknown; - -- Never known unless we have a compile time known value - - elsif not Compile_Time_Known_Value (N) then - return Unknown; + -- Case of a known compile time value, where we can check if it is in + -- the bounds of the given type. - -- General processing with a known compile time value - - else + elsif Compile_Time_Known_Value (N) then declare Lo : Node_Id; Hi : Node_Id; @@ -5423,6 +6178,32 @@ package body Sem_Eval is end if; end if; end; + + -- Here for value not known at compile time. Case of expression subtype + -- is Typ or is a subtype of Typ, and we can assume expression is valid. + -- In this case we know it is in range without knowing its value. + + elsif Assume_Valid + and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ)) + then + return In_Range; + + -- Another special case. For signed integer types, if the target type + -- has Is_Known_Valid set, and the source type does not have a larger + -- size, then the source value must be in range. We exclude biased + -- types, because they bizarrely can generate out of range values. + + elsif Is_Signed_Integer_Type (Etype (N)) + and then Is_Known_Valid (Typ) + and then Esize (Etype (N)) <= Esize (Typ) + and then not Has_Biased_Representation (Etype (N)) + then + return In_Range; + + -- For all other cases, result is unknown + + else + return Unknown; end if; end Test_In_Range; @@ -5445,6 +6226,8 @@ package body Sem_Eval is N : constant Node_Id := Original_Node (Expr); Typ : Entity_Id; E : Entity_Id; + Alt : Node_Id; + Exp : Node_Id; procedure Why_Not_Static_List (L : List_Id); -- A version that can be called on a list of expressions. Finds all @@ -5488,6 +6271,76 @@ package body Sem_Eval is -- Test for constraint error raised if Raises_Constraint_Error (Expr) then + + -- Special case membership to find out which piece to flag + + if Nkind (N) in N_Membership_Test then + if Raises_Constraint_Error (Left_Opnd (N)) then + Why_Not_Static (Left_Opnd (N)); + return; + + elsif Present (Right_Opnd (N)) + and then Raises_Constraint_Error (Right_Opnd (N)) + then + Why_Not_Static (Right_Opnd (N)); + return; + + else + pragma Assert (Present (Alternatives (N))); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + if Raises_Constraint_Error (Alt) then + Why_Not_Static (Alt); + return; + else + Next (Alt); + end if; + end loop; + end if; + + -- Special case a range to find out which bound to flag + + elsif Nkind (N) = N_Range then + if Raises_Constraint_Error (Low_Bound (N)) then + Why_Not_Static (Low_Bound (N)); + return; + + elsif Raises_Constraint_Error (High_Bound (N)) then + Why_Not_Static (High_Bound (N)); + return; + end if; + + -- Special case attribute to see which part to flag + + elsif Nkind (N) = N_Attribute_Reference then + if Raises_Constraint_Error (Prefix (N)) then + Why_Not_Static (Prefix (N)); + return; + end if; + + if Present (Expressions (N)) then + Exp := First (Expressions (N)); + while Present (Exp) loop + if Raises_Constraint_Error (Exp) then + Why_Not_Static (Exp); + return; + end if; + + Next (Exp); + end loop; + end if; + + -- Special case a subtype name + + elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then + Error_Msg_NE + ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr)); + return; + end if; + + -- End of special cases + Error_Msg_N ("!expression raises exception, cannot be static (RM 4.9(34))", N); @@ -5584,6 +6437,10 @@ package body Sem_Eval is end if; end Entity_Case; + elsif Is_Type (E) then + Error_Msg_NE + ("!& is not a static subtype (RM 4.9(26))", N, E); + else Error_Msg_NE ("!& is not static constant or named number " @@ -5653,7 +6510,7 @@ package body Sem_Eval is ("!attribute of generic type is never static " & "(RM 4.9(7,8))", N); - elsif Is_Static_Subtype (E) then + elsif Is_OK_Static_Subtype (E) then null; elsif Is_Scalar_Type (E) then @@ -5747,7 +6604,7 @@ package body Sem_Eval is Why_Not_Static (Expression (N)); if not Is_Scalar_Type (Entity (Subtype_Mark (N))) - or else not Is_Static_Subtype (Entity (Subtype_Mark (N))) + or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) then Error_Msg_N ("!static conversion requires static scalar subtype result " diff --git a/main/gcc/ada/sem_eval.ads b/main/gcc/ada/sem_eval.ads index 207e28ac2ce..23bf2354705 100644 --- a/main/gcc/ada/sem_eval.ads +++ b/main/gcc/ada/sem_eval.ads @@ -52,7 +52,12 @@ package Sem_Eval is -- Is_Static_Expression -- This flag is set on any expression that is static according to the - -- rules in (RM 4.9(3-32)). + -- rules in (RM 4.9(3-32)). This flag should be tested during testing + -- of legality of parts of a larger static expression. For all other + -- contexts that require static expressions, use the separate predicate + -- Is_OK_Static_Expression, since an expression that meets the RM 4.9 + -- requirements, but raises a constraint error when evaluated in a non- + -- static context does not meet the legality requirements. -- Raises_Constraint_Error @@ -63,17 +68,38 @@ package Sem_Eval is -- (i.e. the flag is accurate for static expressions, and conservative -- for non-static expressions. - -- If a static expression does not raise constraint error, then the - -- Raises_Constraint_Error flag is off, and the expression must be computed - -- at compile time, which means that it has the form of either a literal, - -- or a constant that is itself (recursively) either a literal or a - -- constant. + -- If a static expression does not raise constraint error, then it will + -- have the flag Raises_Constraint_Error flag False, and the expression + -- must be computed at compile time, which means that it has the form of + -- either a literal, or a constant that is itself (recursively) either a + -- literal or a constant. -- The above rules must be followed exactly in order for legality checks to -- be accurate. For subexpressions that are not static according to the RM -- definition, they are sometimes folded anyway, but of course in this case -- Is_Static_Expression is not set. + -- When we are analyzing and evaluating static expressions, we propagate + -- both flags accurately. Usually if a subexpression raises a constraint + -- error, then so will its parent expression, and Raise_Constraint_Error + -- will be propagated to this parent. The exception is conditional cases + -- like (True or else 1/0 = 0) which results in an expresion that has the + -- Is_Static_Expression flag True, and Raises_Constraint_Error False. Even + -- though 1/0 would raise an exception, the right operand is never actually + -- executed, so the expression as a whole does not raise CE. + + -- For constructs in the language where static expressions are part of the + -- required semantics, we need an expression that meets the 4.9 rules and + -- does not raise CE. So nearly everywhere, callers should call function + -- Is_OK_Static_Expression rather than Is_Static_Expression. + + -- Finally, the case of static predicates. These are applied only to entire + -- expressions, not to subexpressions, so we do not have the case of having + -- to propagate this information. We handle this case simply by resetting + -- the Is_Static_Expression flag if a static predicate fails. Note that we + -- can't use this simpler approach for the constraint error case because of + -- the (True or else 1/0 = 0) example discussed above. + ------------------------------- -- Compile-Time Known Values -- ------------------------------- @@ -107,6 +133,17 @@ package Sem_Eval is -- Subprograms -- ----------------- + procedure Check_Expression_Against_Static_Predicate + (Expr : Node_Id; + Typ : Entity_Id); + -- Determine whether an arbitrary expression satisfies the static predicate + -- of a type. The routine does nothing if Expr is not known at compile time + -- or Typ lacks a static predicate, otherwise it may emit a warning if the + -- expression is prohibited by the predicate. If the expression is a static + -- expression and it fails a predicate that was not explicitly stated to be + -- a dynamic predicate, then an additional warning is given, and the flag + -- Is_Static_Expression is reset on Expr. + procedure Check_Non_Static_Context (N : Node_Id); -- Deals with the special check required for a static expression that -- appears in a non-static context, i.e. is not part of a larger static @@ -181,18 +218,14 @@ package Sem_Eval is -- for compile time evaluation purposes. Use Compile_Time_Known_Value -- instead (see section on "Compile-Time Known Values" above). - 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 - -- equivalent range attribute references already turned them into the - -- equivalent range). - function Is_OK_Static_Range (N : Node_Id) return Boolean; - -- Like Is_Static_Range, but also makes sure that the 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). + -- 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 @@ -204,14 +237,28 @@ package Sem_Eval is -- -- 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_Predicate field is set ??? + -- 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; - -- Like Is_Static_Subtype but also makes sure that the bounds of the - -- subtype 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). + -- 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; @@ -364,14 +411,6 @@ package Sem_Eval is procedure Eval_Unary_Op (N : Node_Id); procedure Eval_Unchecked_Conversion (N : Node_Id); - function Eval_Static_Predicate_Check - (N : Node_Id; - Typ : Entity_Id) return Boolean; - -- Evaluate a static predicate check applied expression which represents - -- a value that is known at compile time (does not have to be static). The - -- caller has checked that a static predicate does apply to Typ, and thus - -- the type is known to be scalar. - 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 @@ -381,7 +420,8 @@ package Sem_Eval is -- static). The point here is that normally all string literals are static, -- but if this was the result of some sequence of evaluation where values -- were known at compile time but not static, then the result is not - -- static. + -- static. The call has no effect if Raises_Constraint_Error (N) is True, + -- since there is no point in folding if we have an error. procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean); -- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal) @@ -393,7 +433,8 @@ package Sem_Eval is -- consider static). The point here is that normally all integer literals -- are static, but if this was the result of some sequence of evaluation -- where values were known at compile time but not static, then the result - -- is not static. + -- is not static. The call has no effect if Raises_Constraint_Error (N) is + -- True, since there is no point in folding if we have an error. procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean); -- Rewrite N with a new N_Real_Literal node as the result of the compile @@ -404,6 +445,8 @@ package Sem_Eval is -- The point here is that normally all string literals are static, but if -- this was the result of some sequence of evaluation where values were -- known at compile time but not static, then the result is not static. + -- The call has no effect if Raises_Constraint_Error (N) is True, since + -- there is no point in folding if we have an error. function Is_In_Range (N : Node_Id; @@ -411,20 +454,20 @@ package Sem_Eval is Assume_Valid : Boolean := False; Fixed_Int : Boolean := False; Int_Real : Boolean := False) return Boolean; - -- Returns True if it can be guaranteed at compile time that expression is - -- known to be in range of the subtype Typ. A result of False does not mean - -- that the expression is out of range, merely that it cannot be determined - -- at compile time that it is in range. If Typ is a floating point type or - -- Int_Real is set, any integer value is treated as though it was a real - -- value (i.e. the underlying real value is used). In this case we use the - -- corresponding real value, both for the bounds of Typ, and for the value - -- of the expression N. If Typ is a fixed type or a discrete type and - -- Int_Real is False but flag Fixed_Int is True then any fixed-point value - -- is treated as though it was discrete value (i.e. the underlying integer - -- value is used). In this case we use the corresponding integer value, - -- both for the bounds of Typ, and for the value of the expression N. If - -- Typ is a discrete type and Fixed_Int as well as Int_Real are false, - -- integer values are used throughout. + -- Returns True if it can be guaranteed at compile time that expression + -- N is known to be in range of the subtype Typ. A result of False does + -- not mean that the expression is out of range, merely that it cannot be + -- determined at compile time that it is in range. If Typ is a floating + -- point type or Int_Real is set, any integer value is treated as though it + -- was a real value (i.e. the underlying real value is used). In this case + -- we use the corresponding real value, both for the bounds of Typ, and for + -- the value of the expression N. If Typ is a fixed type or a discrete type + -- and Int_Real is False but flag Fixed_Int is True then any fixed-point + -- value is treated as though it was discrete value (i.e. the underlying + -- integer value is used). In this case we use the corresponding integer + -- value, both for the bounds of Typ, and for the value of the expression + -- N. If Typ is a discrete type and Fixed_Int as well as Int_Real are + -- false, integer values are used throughout. -- -- If Assume_Valid is set True, then N is always assumed to contain a valid -- value. If Assume_Valid is set False, then N may be invalid (unless there @@ -460,6 +503,10 @@ package Sem_Eval is -- 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) @@ -487,7 +534,7 @@ package Sem_Eval is -- -- Note that these messages are not continuation messages, instead they are -- separate unconditional messages, marked with '!'. The reason for this is - -- that they can be posted at a different location from the maim message as + -- that they can be posted at a different location from the main message as -- documented above ("appropriate offending component"), and continuation -- messages must always point to the same location as the parent message. diff --git a/main/gcc/ada/sem_intr.adb b/main/gcc/ada/sem_intr.adb index 5fb7442a82c..f61b47aed94 100644 --- a/main/gcc/ada/sem_intr.adb +++ b/main/gcc/ada/sem_intr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Targparm; use Targparm; with Uintp; use Uintp; package body Sem_Intr is @@ -137,7 +136,7 @@ package body Sem_Intr is null; elsif Nkind (Arg1) /= N_String_Literal - and then not Is_Static_Expression (Arg1) + and then not Is_OK_Static_Expression (Arg1) then Error_Msg_FE ("call to & requires static string argument!", N, Nam); @@ -146,12 +145,6 @@ package body Sem_Intr is elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then Error_Msg_NE ("call to & does not permit null string", N, Nam); - - elsif OpenVMS_On_Target - and then String_Length (Strval (Expr_Value_S (Arg1))) > 31 - then - Error_Msg_NE - ("argument in call to & must be 31 characters or less", N, Nam); end if; -- Check for the case of freeing a non-null object which will raise @@ -362,8 +355,12 @@ package body Sem_Intr is -- Source_Location and navigation functions - elsif Nam_In (Nam, Name_File, Name_Line, Name_Source_Location, - Name_Enclosing_Entity) + elsif Nam_In (Nam, Name_File, + Name_Line, + Name_Source_Location, + Name_Enclosing_Entity, + Name_Compilation_Date, + Name_Compilation_Time) then null; diff --git a/main/gcc/ada/sem_mech.adb b/main/gcc/ada/sem_mech.adb index 44a3da91c09..e37aefab020 100644 --- a/main/gcc/ada/sem_mech.adb +++ b/main/gcc/ada/sem_mech.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,18 +23,14 @@ -- -- ------------------------------------------------------------------------------ -with Atree; use Atree; -with Einfo; use Einfo; -with Errout; use Errout; -with Namet; use Namet; -with Nlists; use Nlists; -with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Util; use Sem_Util; -with Sinfo; use Sinfo; -with Snames; use Snames; -with Stand; use Stand; -with Targparm; use Targparm; +with Atree; use Atree; +with Einfo; use Einfo; +with Errout; use Errout; +with Namet; use Namet; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sinfo; use Sinfo; +with Snames; use Snames; package body Sem_Mech is @@ -43,19 +39,13 @@ package body Sem_Mech is ------------------------- procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is - Class : Node_Id; - Param : Node_Id; - - procedure Bad_Class; - -- Signal bad descriptor class name procedure Bad_Mechanism; -- Signal bad mechanism name - procedure Bad_Class is - begin - Error_Msg_N ("unrecognized descriptor class name", Class); - end Bad_Class; + ------------------- + -- Bad_Mechanism -- + ------------------- procedure Bad_Mechanism is begin @@ -70,26 +60,14 @@ package body Sem_Mech is ("mechanism for & has already been set", Mech_Name, Ent); end if; - -- MECHANISM_NAME ::= value | reference | descriptor | short_descriptor + -- MECHANISM_NAME ::= value | reference if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then Set_Mechanism_With_Checks (Ent, By_Copy, Mech_Name); - return; elsif Chars (Mech_Name) = Name_Reference then Set_Mechanism_With_Checks (Ent, By_Reference, Mech_Name); - return; - - elsif Chars (Mech_Name) = Name_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism_With_Checks (Ent, By_Descriptor, Mech_Name); - return; - - elsif Chars (Mech_Name) = Name_Short_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor, Mech_Name); - return; elsif Chars (Mech_Name) = Name_Copy then Error_Msg_N ("bad mechanism name, Value assumed", Mech_Name); @@ -97,138 +75,10 @@ package body Sem_Mech is else Bad_Mechanism; - return; - end if; - - -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | - -- short_descriptor (CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as an indexed component - - elsif Nkind (Mech_Name) = N_Indexed_Component then - Class := First (Expressions (Mech_Name)); - - if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Class)) - then - Bad_Mechanism; - return; - end if; - - -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | - -- short_descriptor (Class => CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as a function call - - elsif Nkind (Mech_Name) = N_Function_Call then - - Param := First (Parameter_Associations (Mech_Name)); - - if Nkind (Name (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Param)) - or else No (Selector_Name (Param)) - or else Chars (Selector_Name (Param)) /= Name_Class - then - Bad_Mechanism; - return; - else - Class := Explicit_Actual_Parameter (Param); end if; else Bad_Mechanism; - return; - end if; - - -- Fall through here with Class set to descriptor class name - - Check_VMS (Mech_Name); - - if Nkind (Class) /= N_Identifier then - Bad_Class; - return; - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_UBS, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_UBSB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_UBA, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_S, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_SB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_A, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism_With_Checks (Ent, By_Descriptor_NCA, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBS, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBSB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_UBA, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_S, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_SB, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_A, Mech_Name); - - elsif Chars (Name (Mech_Name)) = Name_Short_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism_With_Checks (Ent, By_Short_Descriptor_NCA, Mech_Name); - - else - Bad_Class; - return; end if; end Set_Mechanism_Value; @@ -241,18 +91,10 @@ package body Sem_Mech is Mech : Mechanism_Type; Enod : Node_Id) is - begin - -- Right now we only do some checks for functions returning arguments - -- by descriptor. Probably mode checks need to be added here ??? - - if Mech in Descriptor_Codes and then not Is_Formal (Ent) then - if Is_Record_Type (Etype (Ent)) then - Error_Msg_N ("??records cannot be returned by Descriptor", Enod); - return; - end if; - end if; + pragma Unreferenced (Enod); - -- If we fall through, all checks have passed + begin + -- Right now we don't do any checks, should we do more ??? Set_Mechanism (Ent, Mech); end Set_Mechanism_With_Checks; @@ -462,23 +304,10 @@ package body Sem_Mech is when Convention_Fortran => - -- In OpenVMS, pass character and string types using - -- Short_Descriptor(S) - - if OpenVMS_On_Target - and then (Root_Type (Typ) = Standard_Character - or else - (Is_Array_Type (Typ) - and then - Root_Type (Component_Type (Typ)) = - Standard_Character)) - then - Set_Mechanism (Formal, By_Short_Descriptor_S); - -- Access types are passed by default (presumably this -- will mean they are passed by copy) - elsif Is_Access_Type (Typ) then + if Is_Access_Type (Typ) then null; -- For now, we pass all other parameters by reference. diff --git a/main/gcc/ada/sem_mech.ads b/main/gcc/ada/sem_mech.ads index 93f6080f1f4..464c9bd9e75 100644 --- a/main/gcc/ada/sem_mech.ads +++ b/main/gcc/ada/sem_mech.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1996-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 @@ package Sem_Mech is ------------------------------------------------- -- For parameters passed to subprograms, and for function return values, - -- as passing mechanism is defined. The entity attribute Mechanism returns + -- a passing mechanism is defined. The entity attribute Mechanism returns -- an indication of the mechanism, and Set_Mechanism can be used to set -- the mechanism. At the program level, there are three ways to explicitly -- set the mechanism: @@ -87,42 +87,8 @@ package Sem_Mech is -- special information) is determined by the backend in accordance with -- requirements imposed by the ABI as interpreted for Ada. - By_Descriptor : constant Mechanism_Type := -3; - By_Descriptor_UBS : constant Mechanism_Type := -4; - By_Descriptor_UBSB : constant Mechanism_Type := -5; - By_Descriptor_UBA : constant Mechanism_Type := -6; - By_Descriptor_S : constant Mechanism_Type := -7; - By_Descriptor_SB : constant Mechanism_Type := -8; - By_Descriptor_A : constant Mechanism_Type := -9; - By_Descriptor_NCA : constant Mechanism_Type := -10; - By_Short_Descriptor : constant Mechanism_Type := -11; - By_Short_Descriptor_UBS : constant Mechanism_Type := -12; - By_Short_Descriptor_UBSB : constant Mechanism_Type := -13; - By_Short_Descriptor_UBA : constant Mechanism_Type := -14; - By_Short_Descriptor_S : constant Mechanism_Type := -15; - By_Short_Descriptor_SB : constant Mechanism_Type := -16; - By_Short_Descriptor_A : constant Mechanism_Type := -17; - By_Short_Descriptor_NCA : constant Mechanism_Type := -18; - -- These values are used only in OpenVMS ports of GNAT. Pass by descriptor - -- is forced, as described in the OpenVMS ABI. The suffix indicates the - -- descriptor type: - -- - -- UBS unaligned bit string - -- UBSB aligned bit string with arbitrary bounds - -- UBA unaligned bit array - -- S string, also a scalar or access type parameter - -- SB string with arbitrary bounds - -- A contiguous array - -- NCA non-contiguous array - -- - -- Note: the form with no suffix is used if the Import/Export pragma - -- uses the simple form of the mechanism name where no descriptor - -- type is supplied. In this case the back end assigns a descriptor - -- type based on the Ada type in accordance with the OpenVMS ABI. - - subtype Descriptor_Codes is Mechanism_Type - range By_Short_Descriptor_NCA .. By_Descriptor; - -- Subtype including all descriptor mechanisms + pragma Assert (Mechanism_Type'First = -2); + -- Check definition in types is right! -- All the above special values are non-positive. Positive values for -- Mechanism_Type values have a special meaning. They are used only in diff --git a/main/gcc/ada/sem_prag.adb b/main/gcc/ada/sem_prag.adb index c32d89bbf81..dc084f9e13e 100644 --- a/main/gcc/ada/sem_prag.adb +++ b/main/gcc/ada/sem_prag.adb @@ -68,7 +68,6 @@ with Sem_Mech; use Sem_Mech; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; -with Sem_VFpt; use Sem_VFpt; with Sem_Warn; use Sem_Warn; with Stand; use Stand; with Sinfo; use Sinfo; @@ -125,8 +124,7 @@ package body Sem_Prag is -- If the External parameter is given as an identifier (or there is no -- External parameter, so that the Internal identifier is used), then -- the external name is the characters of the identifier, translated - -- to all upper case letters for OpenVMS versions of GNAT, and to all - -- lower case letters for all other versions + -- to all lower case letters. -- Note: the external name specified or implied by any of these special -- Import_xxx or Export_xxx pragmas override an external or link name @@ -237,17 +235,6 @@ package body Sem_Prag is -- with visible refinement available in the corresponding mode. Flag -- Has_Null_State is set when at least state has a null refinement. - procedure Collect_Subprogram_Inputs_Outputs - (Subp_Id : Entity_Id; - Subp_Inputs : in out Elist_Id; - Subp_Outputs : in out Elist_Id; - Global_Seen : out Boolean); - -- Subsidiary to the analysis of pragma Depends, Global, Refined_Depends - -- and Refined_Global. Gather all inputs and outputs of subprogram Subp_Id - -- in lists Subp_Inputs and Subp_Outputs. If the case where the subprogram - -- has no inputs and/oroutputs, the returned list is No_Elist. Global_Seen - -- is set when the related subprogram has pragma [Refined_]Global. - function Find_Related_Subprogram_Or_Body (Prag : Node_Id; Do_Checks : Boolean := False) return Node_Id; @@ -315,7 +302,19 @@ package body Sem_Prag is -- pragma. Entity name for unit and its parents is taken from item in -- previous with_clause that mentions the unit. + Dummy : Integer := 0; + pragma Volatile (Dummy); + -- Dummy volatile integer used in bodies of ip/rv to prevent optimization + + procedure ip; + pragma No_Inline (ip); + -- A dummy procedure called when pragma Inspection_Point is analyzed. This + -- is just to help debugging the front end. If a pragma Inspection_Point + -- is added to a source program, then breaking on ip will get you to that + -- point in the program. + procedure rv; + pragma No_Inline (rv); -- This is a dummy function called by the processing for pragma Reviewable. -- It is there for assisting front end debugging. By placing a Reviewable -- pragma in the source program, a breakpoint on rv catches this place in @@ -327,11 +326,7 @@ package body Sem_Prag is procedure Add_Item (Item : Entity_Id; To_List : in out Elist_Id) is begin - if No (To_List) then - To_List := New_Elmt_List; - end if; - - Append_Elmt (Item, To_List); + Append_New_Elmt (Item, To => To_List); end Add_Item; ------------------------------- @@ -1822,29 +1817,28 @@ package body Sem_Prag is (N : Node_Id; Expr_Val : out Boolean) is - Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); - Obj : constant Node_Id := Get_Pragma_Arg (Arg1); - Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1)); + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); + Obj_Id : constant Entity_Id := Entity (Get_Pragma_Arg (Arg1)); + Expr : constant Node_Id := Get_Pragma_Arg (Next (Arg1)); begin Error_Msg_Name_1 := Pragma_Name (N); - -- The Async / Effective pragmas must apply to a volatile object other - -- than a formal subprogram parameter (SPARK RM 7.1.3(2)). + -- An external property pragma must apply to an effectively volatile + -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)). + -- The check is performed at the end of the declarative region due to a + -- possible out-of-order arrangement of pragmas: - if Is_SPARK_Volatile_Object (Obj) then - if Is_Entity_Name (Obj) - and then Present (Entity (Obj)) - and then Is_Formal (Entity (Obj)) - then - SPARK_Msg_N ("external property % cannot apply to parameter", N); - end if; - else + -- Obj : ...; + -- pragma Async_Readers (Obj); + -- pragma Volatile (Obj); + + if not Is_Effectively_Volatile (Obj_Id) then SPARK_Msg_N ("external property % must apply to a volatile object", N); end if; - -- Ensure that the expression (if present) is static Boolean. A missing + -- Ensure that the Boolean expression (if present) is static. A missing -- argument defaults the value to True (SPARK RM 7.1.2(5)). Expr_Val := True; @@ -1852,10 +1846,9 @@ package body Sem_Prag is if Present (Expr) then Analyze_And_Resolve (Expr, Standard_Boolean); - if Is_Static_Expression (Expr) then + if Is_OK_Static_Expression (Expr) then Expr_Val := Is_True (Expr_Value (Expr)); else - Error_Msg_Name_1 := Pragma_Name (N); SPARK_Msg_N ("expression of % must be static", Expr); end if; end if; @@ -2022,10 +2015,11 @@ package body Sem_Prag is -- SPARK_Mode is on as they are not standard Ada legality -- rules. - elsif SPARK_Mode = On and then Is_SPARK_Volatile (Item_Id) then - - -- A volatile object cannot appear as a global item of a - -- function (SPARK RM 7.1.3(9)). + elsif SPARK_Mode = On + and then Is_Effectively_Volatile (Item_Id) + then + -- An effectively volatile object cannot appear as a global + -- item of a function (SPARK RM 7.1.3(9)). if Ekind_In (Spec_Id, E_Function, E_Generic_Function) then Error_Msg_NE @@ -2033,8 +2027,9 @@ package body Sem_Prag is & "function", Item, Item_Id); return; - -- A volatile object with property Effective_Reads set to - -- True must have mode Output or In_Out. + -- An effectively volatile object with external property + -- Effective_Reads set to True must have mode Output or + -- In_Out. elsif Effective_Reads_Enabled (Item_Id) and then Global_Mode = Name_Input @@ -2368,7 +2363,7 @@ package body Sem_Prag is -- final place yet. A direct analysis may generate side effects and this -- is not desired at this point. - Preanalyze_And_Resolve (Expr, Standard_Boolean); + Preanalyze_Assert_Expression (Expr, Standard_Boolean); end Analyze_Initial_Condition_In_Decl_Part; -------------------------------------- @@ -2890,14 +2885,15 @@ package body Sem_Prag is -- Check the specified argument Arg to make sure that it is a valid -- queuing policy name. If not give error and raise Pragma_Exit. - procedure Check_Arg_Is_Static_Expression + procedure Check_Arg_Is_OK_Static_Expression (Arg : Node_Id; Typ : Entity_Id := Empty); -- Check the specified argument Arg to make sure that it is a static -- expression of the given type (i.e. it will be analyzed and resolved -- using this type, which can be any valid argument to Resolve, e.g. -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If - -- Typ is left Empty, then any static expression is allowed. + -- Typ is left Empty, then any static expression is allowed. Includes + -- checking that the argument does not raise Constraint_Error. procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id); -- Check the specified argument Arg to make sure that it is a valid task @@ -2941,14 +2937,15 @@ package body Sem_Prag is -- This procedure checks for possible duplications if this is the export -- case, and if found, issues an appropriate error message. - procedure Check_Expr_Is_Static_Expression + procedure Check_Expr_Is_OK_Static_Expression (Expr : Node_Id; Typ : Entity_Id := Empty); -- Check the specified expression Expr to make sure that it is a static -- expression of the given type (i.e. it will be analyzed and resolved -- using this type, which can be any valid argument to Resolve, e.g. -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If - -- Typ is left Empty, then any static expression is allowed. + -- Typ is left Empty, then any static expression is allowed. Includes + -- checking that the expression does not raise Constraint_Error. procedure Check_First_Subtype (Arg : Node_Id); -- Checks that Arg, whose expression is an entity name, references a @@ -3224,16 +3221,6 @@ package body Sem_Prag is -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is -- Name_Suppress for Disable and Name_Unsuppress for Enable. - procedure Process_Extended_Import_Export_Exception_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Form : Node_Id; - Arg_Code : Node_Id); - -- Common processing for the pragmas Import/Export_Exception. The three - -- arguments correspond to the three named parameters of the pragma. An - -- argument is empty if the corresponding parameter is not present in - -- the pragma. - procedure Process_Extended_Import_Export_Object_Pragma (Arg_Internal : Node_Id; Arg_External : Node_Id; @@ -3257,8 +3244,7 @@ package body Sem_Prag is Arg_Parameter_Types : Node_Id; Arg_Result_Type : Node_Id := Empty; Arg_Mechanism : Node_Id; - Arg_Result_Mechanism : Node_Id := Empty; - Arg_First_Optional_Parameter : Node_Id := Empty); + Arg_Result_Mechanism : Node_Id := Empty); -- Common processing for all extended Import and Export pragmas applying -- to subprograms. The caller omits any arguments that do not apply to -- the pragma in question (for example, Arg_Result_Type can be non-Empty @@ -3480,14 +3466,14 @@ package body Sem_Prag is and then Is_Private_Descendant (Pack_Id) then -- A variable or state abstraction which is part of the - -- visible state of a private child unit (or a public - -- descendant thereof) shall have its Part_Of indicator - -- specified; the Part_Of indicator shall denote a state - -- abstraction declared by either the parent unit of the - -- private unit or by a public descendant of that parent unit. + -- visible state of a private child unit (or one of its public + -- descendants) must have its Part_Of indicator specified. The + -- Part_Of indicator must denote a state abstraction declared + -- by either the parent unit of the private unit or by a public + -- descendant of that parent unit. - -- Find nearest nearest private ancestor (which can be the - -- current unit itself). + -- Find nearest private ancestor (which can be the current unit + -- itself). Parent_Unit := Pack_Id; while Present (Parent_Unit) loop @@ -3702,7 +3688,7 @@ package body Sem_Prag is -- Static expression that raises Constraint_Error. This has -- already been flagged, so just exit from pragma processing. - elsif Is_Static_Expression (Argx) then + elsif Is_OK_Static_Expression (Argx) then raise Pragma_Exit; -- Here we have a real error (non-static expression) @@ -3987,17 +3973,17 @@ package body Sem_Prag is end if; end Check_Arg_Is_Queuing_Policy; - ------------------------------------ - -- Check_Arg_Is_Static_Expression -- - ------------------------------------ + --------------------------------------- + -- Check_Arg_Is_OK_Static_Expression -- + --------------------------------------- - procedure Check_Arg_Is_Static_Expression + procedure Check_Arg_Is_OK_Static_Expression (Arg : Node_Id; Typ : Entity_Id := Empty) is begin - Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ); - end Check_Arg_Is_Static_Expression; + Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ); + end Check_Arg_Is_OK_Static_Expression; ------------------------------------------ -- Check_Arg_Is_Task_Dispatching_Policy -- @@ -4341,11 +4327,11 @@ package body Sem_Prag is end if; end Check_Duplicated_Export_Name; - ------------------------------------- - -- Check_Expr_Is_Static_Expression -- - ------------------------------------- + ---------------------------------------- + -- Check_Expr_Is_OK_Static_Expression -- + ---------------------------------------- - procedure Check_Expr_Is_Static_Expression + procedure Check_Expr_Is_OK_Static_Expression (Expr : Node_Id; Typ : Entity_Id := Empty) is @@ -4376,7 +4362,7 @@ package body Sem_Prag is -- Static expression that raises Constraint_Error. This has already -- been flagged, so just exit from pragma processing. - elsif Is_Static_Expression (Expr) then + elsif Is_OK_Static_Expression (Expr) then raise Pragma_Exit; -- Finally, we have a real error @@ -4388,7 +4374,7 @@ package body Sem_Prag is Expr); raise Pragma_Exit; end if; - end Check_Expr_Is_Static_Expression; + end Check_Expr_Is_OK_Static_Expression; ------------------------- -- Check_First_Subtype -- @@ -5246,9 +5232,7 @@ package body Sem_Prag is -- The copy is needed because the pragma is expanded into other -- constructs which are not acceptable in the N_Contract node. - if Acts_As_Spec (PO) - and then GNATprove_Mode - then + if Acts_As_Spec (PO) and then GNATprove_Mode then declare Prag : constant Node_Id := New_Copy_Tree (N); @@ -5257,7 +5241,7 @@ package body Sem_Prag is Preanalyze_Assert_Expression (Get_Pragma_Arg - (First (Pragma_Argument_Associations (Prag))), + (First (Pragma_Argument_Associations (Prag))), Standard_Boolean); -- Preanalyze the corresponding aspect (if any) @@ -5450,13 +5434,13 @@ package body Sem_Prag is ((Name_Name, Name_Mode, Name_Requires, Name_Ensures)); Check_Optional_Identifier (Arg1, Name_Name); - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); -- In ASIS mode, for a pragma generated from a source aspect, also -- analyze the original aspect expression. if ASIS_Mode and then Present (Corresponding_Aspect (N)) then - Check_Expr_Is_Static_Expression + Check_Expr_Is_OK_Static_Expression (Original_Node (Get_Pragma_Arg (Arg1)), Standard_String); end if; @@ -5480,7 +5464,7 @@ package body Sem_Prag is -- Test-case should only appear in package spec unit if Get_Source_Unit (N) = No_Unit - or else not Nkind_In (Sinfo.Unit (Cunit (Get_Source_Unit (N))), + or else not Nkind_In (Sinfo.Unit (Cunit (Current_Sem_Unit)), N_Package_Declaration, N_Generic_Package_Declaration) then @@ -5722,6 +5706,9 @@ package body Sem_Prag is Comps : List_Id := No_List; Exprs : List_Id := No_List; + CFSD : constant Boolean := Get_Comes_From_Source_Default; + -- Used to restore Comes_From_Source_Default + begin -- The argument is already in aggregate form, but the presence of a -- name causes this to be interpreted as a named association which in @@ -5747,6 +5734,10 @@ package body Sem_Prag is return; end if; + -- Everything comes from source if the original comes from source + + Set_Comes_From_Source_Default (Comes_From_Source (Arg)); + -- Positional argument is transformed into an aggregate with an -- Expressions list. @@ -5761,7 +5752,6 @@ package body Sem_Prag is Make_Component_Association (Loc, Choices => New_List (Make_Identifier (Loc, Chars (Arg))), Expression => Relocate_Node (Expr))); - end if; -- Remove the pragma argument name as this information has been @@ -5773,6 +5763,10 @@ package body Sem_Prag is Make_Aggregate (Loc, Component_Associations => Comps, Expressions => Exprs)); + + -- Restore Comes_From_Source default + + Set_Comes_From_Source_Default (CFSD); end Ensure_Aggregate_Form; ------------------ @@ -5858,8 +5852,8 @@ package body Sem_Prag is if Nkind (P) = N_Compilation_Unit then Unit_Kind := Nkind (Unit (P)); - if Unit_Kind = N_Subprogram_Declaration - or else Unit_Kind = N_Package_Declaration + if Nkind_In (Unit_Kind, N_Subprogram_Declaration, + N_Package_Declaration) or else Unit_Kind in N_Generic_Declaration then Unit_Name := Defining_Entity (Unit (P)); @@ -6315,14 +6309,6 @@ package body Sem_Prag is Set_Treat_As_Volatile (E); Set_Treat_As_Volatile (Underlying_Type (E)); - -- The following check is only relevant when SPARK_Mode is on as - -- this is not a standard Ada legality rule. Volatile types are - -- not allowed (SPARK RM C.6(1)). - - if SPARK_Mode = On and then Prag_Id = Pragma_Volatile then - Error_Msg_N ("volatile type not allowed", E); - end if; - elsif K = N_Object_Declaration or else (K = N_Component_Declaration and then Original_Record_Component (E) = E) @@ -6410,7 +6396,7 @@ package body Sem_Prag is begin Check_Arg_Count (2); Check_No_Identifiers; - Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); Analyze_And_Resolve (Arg1x, Standard_Boolean); if Compile_Time_Known_Value (Arg1x) then @@ -6877,14 +6863,10 @@ package body Sem_Prag is elsif Is_Convention_Name (Cname) then C := Get_Convention_Id (Chars (Get_Pragma_Arg (Arg1))); - -- In DEC VMS, it seems that there is an undocumented feature that - -- any unrecognized convention is treated as the default, which for - -- us is convention C. It does not seem so terrible to do this - -- unconditionally, silently in the VMS case, and with a warning - -- in the non-VMS case. + -- Otherwise warn on unrecognized convention else - if Warn_On_Export_Import and not OpenVMS_On_Target then + if Warn_On_Export_Import then Error_Msg_N ("??unrecognized convention name, C assumed", Get_Pragma_Arg (Arg1)); @@ -7165,69 +7147,6 @@ package body Sem_Prag is Analyze (N); end Process_Disable_Enable_Atomic_Sync; - ----------------------------------------------------- - -- Process_Extended_Import_Export_Exception_Pragma -- - ----------------------------------------------------- - - procedure Process_Extended_Import_Export_Exception_Pragma - (Arg_Internal : Node_Id; - Arg_External : Node_Id; - Arg_Form : Node_Id; - Arg_Code : Node_Id) - is - Def_Id : Entity_Id; - Code_Val : Uint; - - begin - if not OpenVMS_On_Target then - Error_Pragma - ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; - - Process_Extended_Import_Export_Internal_Arg (Arg_Internal); - Def_Id := Entity (Arg_Internal); - - if Ekind (Def_Id) /= E_Exception then - Error_Pragma_Arg - ("pragma% must refer to declared exception", Arg_Internal); - end if; - - Set_Extended_Import_Export_External_Name (Def_Id, Arg_External); - - if Present (Arg_Form) then - Check_Arg_Is_One_Of (Arg_Form, Name_Ada, Name_VMS); - end if; - - if Present (Arg_Form) - and then Chars (Arg_Form) = Name_Ada - then - null; - else - Set_Is_VMS_Exception (Def_Id); - Set_Exception_Code (Def_Id, No_Uint); - end if; - - if Present (Arg_Code) then - if not Is_VMS_Exception (Def_Id) then - Error_Pragma_Arg - ("Code option for pragma% not allowed for Ada case", - Arg_Code); - end if; - - Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer); - Code_Val := Expr_Value (Arg_Code); - - if not UI_Is_In_Int_Range (Code_Val) then - Error_Pragma_Arg - ("Code option for pragma% must be in 32-bit range", - Arg_Code); - - else - Set_Exception_Code (Def_Id, Code_Val); - end if; - end if; - end Process_Extended_Import_Export_Exception_Pragma; - ------------------------------------------------- -- Process_Extended_Import_Export_Internal_Arg -- ------------------------------------------------- @@ -7385,8 +7304,7 @@ package body Sem_Prag is Arg_Parameter_Types : Node_Id; Arg_Result_Type : Node_Id := Empty; Arg_Mechanism : Node_Id; - Arg_Result_Mechanism : Node_Id := Empty; - Arg_First_Optional_Parameter : Node_Id := Empty) + Arg_Result_Mechanism : Node_Id := Empty) is Ent : Entity_Id; Def_Id : Entity_Id; @@ -7394,7 +7312,6 @@ package body Sem_Prag is Formal : Entity_Id; Ambiguous : Boolean; Match : Boolean; - Dval : Node_Id; function Same_Base_Type (Ptype : Node_Id; @@ -7775,63 +7692,6 @@ package body Sem_Prag is end if; end; end if; - - -- Process First_Optional_Parameter argument if present. We have - -- already checked that this is only allowed for the Import case. - - if Present (Arg_First_Optional_Parameter) then - if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then - Error_Pragma_Arg - ("first optional parameter must be formal parameter name", - Arg_First_Optional_Parameter); - end if; - - Formal := First_Formal (Ent); - loop - if No (Formal) then - Error_Pragma_Arg - ("specified formal parameter& not found", - Arg_First_Optional_Parameter); - end if; - - exit when Chars (Formal) = - Chars (Arg_First_Optional_Parameter); - - Next_Formal (Formal); - end loop; - - Set_First_Optional_Parameter (Ent, Formal); - - -- Check specified and all remaining formals have right form - - while Present (Formal) loop - if Ekind (Formal) /= E_In_Parameter then - Error_Msg_NE - ("optional formal& is not of mode in!", - Arg_First_Optional_Parameter, Formal); - - else - Dval := Default_Value (Formal); - - if No (Dval) then - Error_Msg_NE - ("optional formal& does not have default value!", - Arg_First_Optional_Parameter, Formal); - - elsif Compile_Time_Known_Value_Or_Aggr (Dval) then - null; - - else - Error_Msg_FE - ("default value for optional formal& is non-static!", - Arg_First_Optional_Parameter, Formal); - end if; - end if; - - Set_Is_Optional_Parameter (Formal); - Next_Formal (Formal); - end loop; - end if; end Process_Extended_Import_Export_Subprogram_Pragma; -------------------------- @@ -7978,8 +7838,13 @@ package body Sem_Prag is -- the code generator making an implicit initialization explicit. elsif Present (Expression (Parent (Def_Id))) - and then Comes_From_Source (Expression (Parent (Def_Id))) + and then Comes_From_Source + (Original_Node (Expression (Parent (Def_Id)))) then + -- Set imported flag to prevent cascaded errors + + Set_Is_Imported (Def_Id); + Error_Msg_Sloc := Sloc (Def_Id); Error_Pragma_Arg ("no initialization allowed for declaration of& #", @@ -7987,7 +7852,13 @@ package body Sem_Prag is Arg2); else - Set_Imported (Def_Id); + -- If the pragma comes from an aspect specification the + -- Is_Imported flag has already been set. + + if not From_Aspect_Specification (N) then + Set_Imported (Def_Id); + end if; + Process_Interface_Name (Def_Id, Arg3, Arg4); -- Note that we do not set Is_Public here. That's because we @@ -8062,7 +7933,12 @@ package body Sem_Prag is exit; else - Set_Imported (Def_Id); + -- If the pragma comes from an aspect specification the + -- Is_Imported flag has already been set. + + if not From_Aspect_Specification (N) then + Set_Imported (Def_Id); + end if; -- Reject an Import applied to an abstract subprogram @@ -8117,7 +7993,37 @@ package body Sem_Prag is end if; end; - Set_Has_Completion (Def_Id); + -- If the pragma comes from an aspect specification, there + -- must be an Import aspect specified as well. In the rare + -- case where Import is set to False, the suprogram needs to + -- have a local completion. + + declare + Imp_Aspect : constant Node_Id := + Find_Aspect (Def_Id, Aspect_Import); + Expr : Node_Id; + + begin + if Present (Imp_Aspect) + and then Present (Expression (Imp_Aspect)) + then + Expr := Expression (Imp_Aspect); + Analyze_And_Resolve (Expr, Standard_Boolean); + + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_True + then + Set_Has_Completion (Def_Id); + end if; + + -- If there is no expression, the default is True, as for + -- all boolean aspects. Same for the older pragma. + + else + Set_Has_Completion (Def_Id); + end if; + end; + Process_Interface_Name (Def_Id, Arg3, Arg4); end if; @@ -8237,7 +8143,8 @@ package body Sem_Prag is else -- As only a string is allowed, Check_Arg_Is_External_Name -- isn't called. - Check_Arg_Is_Static_Expression (Arg3, Standard_String); + + Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); end if; if Present (Arg4) then @@ -8256,7 +8163,7 @@ package body Sem_Prag is elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then Check_No_Link_Name; Check_Arg_Count (3); - Check_Arg_Is_Static_Expression (Arg3, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); Process_Import_Predefined_Type; @@ -8749,7 +8656,7 @@ package body Sem_Prag is -- Check expressions for external name and link name are static if Present (Ext_Nam) then - Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String); + Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String); Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True); -- Verify that external name is not the name of a local entity, @@ -8794,7 +8701,7 @@ package body Sem_Prag is end if; if Present (Link_Nam) then - Check_Arg_Is_Static_Expression (Link_Nam, Standard_String); + Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String); Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False); end if; @@ -8985,10 +8892,10 @@ package body Sem_Prag is ("\unless also specified in body or spec", N); return; - -- If we have a No_Elaboration_Code pragma that we - -- accept, then it needs to be added to the configuration - -- restrcition set so that we get proper application to - -- other units in the main extended source as required. + -- If we accept a No_Elaboration_Code restriction, then it + -- needs to be added to the configuration restriction set so + -- that we get proper application to other units in the main + -- extended source as required. else Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); @@ -9392,13 +9299,15 @@ package body Sem_Prag is Set_Is_Public (E); Set_Is_Statically_Allocated (E); - -- Warn if the corresponding W flag is set and the pragma comes - -- from source. The latter may not be true e.g. on VMS where we - -- expand export pragmas for exception codes associated with - -- imported or exported exceptions. We do not want to generate - -- a warning for something that the user did not write. + -- Warn if the corresponding W flag is set if Warn_On_Export_Import + + -- Only do this for something that was in the source. Not + -- clear if this can be False now (there used for sure to be + -- cases on some systems where it was False), but anyway the + -- test is harmless if not needed, so it is retained. + and then Comes_From_Source (Arg) then Error_Msg_NE @@ -9592,27 +9501,10 @@ package body Sem_Prag is -- form created by the parser. procedure Set_Mechanism_Value (Ent : Entity_Id; Mech_Name : Node_Id) is - Class : Node_Id; - Param : Node_Id; - Mech_Name_Id : Name_Id; - - procedure Bad_Class; - pragma No_Return (Bad_Class); - -- Signal bad descriptor class name - procedure Bad_Mechanism; pragma No_Return (Bad_Mechanism); -- Signal bad mechanism name - --------------- - -- Bad_Class -- - --------------- - - procedure Bad_Class is - begin - Error_Pragma_Arg ("unrecognized descriptor class name", Class); - end Bad_Class; - ------------------------- -- Bad_Mechanism_Value -- ------------------------- @@ -9630,8 +9522,7 @@ package body Sem_Prag is ("mechanism for & has already been set", Mech_Name, Ent); end if; - -- MECHANISM_NAME ::= value | reference | descriptor | - -- short_descriptor + -- MECHANISM_NAME ::= value | reference if Nkind (Mech_Name) = N_Identifier then if Chars (Mech_Name) = Name_Value then @@ -9642,24 +9533,6 @@ package body Sem_Prag is Set_Mechanism (Ent, By_Reference); return; - elsif Chars (Mech_Name) = Name_Descriptor then - Check_VMS (Mech_Name); - - -- Descriptor => Short_Descriptor if pragma was given - - if Short_Descriptors then - Set_Mechanism (Ent, By_Short_Descriptor); - else - Set_Mechanism (Ent, By_Descriptor); - end if; - - return; - - elsif Chars (Mech_Name) = Name_Short_Descriptor then - Check_VMS (Mech_Name); - Set_Mechanism (Ent, By_Short_Descriptor); - return; - elsif Chars (Mech_Name) = Name_Copy then Error_Pragma_Arg ("bad mechanism name, Value assumed", Mech_Name); @@ -9668,141 +9541,9 @@ package body Sem_Prag is Bad_Mechanism; end if; - -- MECHANISM_NAME ::= descriptor (CLASS_NAME) | - -- short_descriptor (CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as an indexed component - - elsif Nkind (Mech_Name) = N_Indexed_Component then - Class := First (Expressions (Mech_Name)); - - if Nkind (Prefix (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Prefix (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Class)) - then - Bad_Mechanism; - else - Mech_Name_Id := Chars (Prefix (Mech_Name)); - - -- Change Descriptor => Short_Descriptor if pragma was given - - if Mech_Name_Id = Name_Descriptor - and then Short_Descriptors - then - Mech_Name_Id := Name_Short_Descriptor; - end if; - end if; - - -- MECHANISM_NAME ::= descriptor (Class => CLASS_NAME) | - -- short_descriptor (Class => CLASS_NAME) - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca - - -- Note: this form is parsed as a function call - - elsif Nkind (Mech_Name) = N_Function_Call then - Param := First (Parameter_Associations (Mech_Name)); - - if Nkind (Name (Mech_Name)) /= N_Identifier - or else - not Nam_In (Chars (Name (Mech_Name)), Name_Descriptor, - Name_Short_Descriptor) - or else Present (Next (Param)) - or else No (Selector_Name (Param)) - or else Chars (Selector_Name (Param)) /= Name_Class - then - Bad_Mechanism; - else - Class := Explicit_Actual_Parameter (Param); - Mech_Name_Id := Chars (Name (Mech_Name)); - end if; - else Bad_Mechanism; end if; - - -- Fall through here with Class set to descriptor class name - - Check_VMS (Mech_Name); - - if Nkind (Class) /= N_Identifier then - Bad_Class; - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism (Ent, By_Descriptor_UBS); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism (Ent, By_Descriptor_UBSB); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism (Ent, By_Descriptor_UBA); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism (Ent, By_Descriptor_S); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism (Ent, By_Descriptor_SB); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism (Ent, By_Descriptor_A); - - elsif Mech_Name_Id = Name_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism (Ent, By_Descriptor_NCA); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBS - then - Set_Mechanism (Ent, By_Short_Descriptor_UBS); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBSB - then - Set_Mechanism (Ent, By_Short_Descriptor_UBSB); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_UBA - then - Set_Mechanism (Ent, By_Short_Descriptor_UBA); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_S - then - Set_Mechanism (Ent, By_Short_Descriptor_S); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_SB - then - Set_Mechanism (Ent, By_Short_Descriptor_SB); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_A - then - Set_Mechanism (Ent, By_Short_Descriptor_A); - - elsif Mech_Name_Id = Name_Short_Descriptor - and then Chars (Class) = Name_NCA - then - Set_Mechanism (Ent, By_Short_Descriptor_NCA); - - else - Bad_Class; - end if; end Set_Mechanism_Value; -------------------------- @@ -10038,6 +9779,19 @@ package body Sem_Prag is Prag_Id := Get_Pragma_Id (Pname); Pname := Original_Aspect_Name (N); + -- Capture setting of Opt.Uneval_Old + + 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; + -- Check applicable policy. We skip this if Is_Checked or Is_Ignored -- is already set, indicating that we have already checked the policy -- at the right point. This happens for example in the case of a pragma @@ -10373,7 +10127,7 @@ package body Sem_Prag is if Present (Expr) then Analyze_And_Resolve (Expr, Standard_Boolean); - if Is_Static_Expression (Expr) then + if Is_OK_Static_Expression (Expr) then Expr_Val := Is_True (Expr_Value (Expr)); else SPARK_Msg_N @@ -10503,10 +10257,23 @@ package body Sem_Prag is Is_Null : Boolean) is begin - -- The generated state abstraction reuses the same chars - -- from the original state declaration. Decorate the entity. + -- The abstract state may be semi-declared when the related + -- package was withed through a limited with clause. In that + -- case reuse the entity to fully declare the state. + + if Present (Decl) and then Present (Entity (Decl)) then + State_Id := Entity (Decl); + + -- Otherwise the elaboration of pragma Abstract_State + -- declares the state. + + else + State_Id := Make_Defining_Identifier (Loc, Nam); - State_Id := Make_Defining_Identifier (Loc, Nam); + if Present (Decl) then + Set_Entity (Decl, State_Id); + end if; + end if; -- Null states never come from source @@ -11013,11 +10780,11 @@ package body Sem_Prag is Check_Arg_Count (0); -- If Address is a private type, then set the flag to allow - -- integer address values. If Address is not private (e.g. on - -- VMS, where it is an integer type), then this pragma has no - -- purpose, so it is simply ignored. + -- integer address values. If Address is not private, then this + -- pragma has no purpose, so it is simply ignored. Not clear if + -- there are any such targets now. - if Is_Private_Type (RTE (RE_Address)) then + if Opt.Address_Is_Private then Opt.Allow_Integer_Address := True; end if; @@ -11140,20 +10907,17 @@ package body Sem_Prag is Pragma_Assume | Pragma_Loop_Invariant => Assert : declare - Expr : Node_Id; - Newa : List_Id; - - Has_Loop_Entry : Boolean; - -- Set True by - - function Contains_Loop_Entry return Boolean; - -- Tests if Expr contains a Loop_Entry attribute reference + function Contains_Loop_Entry (Expr : Node_Id) return Boolean; + -- Determine whether expression Expr contains a Loop_Entry + -- attribute reference. ------------------------- -- Contains_Loop_Entry -- ------------------------- - function Contains_Loop_Entry return Boolean is + function Contains_Loop_Entry (Expr : Node_Id) return Boolean is + Has_Loop_Entry : Boolean := False; + function Process (N : Node_Id) return Traverse_Result; -- Process function for traversal to look for Loop_Entry @@ -11178,11 +10942,15 @@ package body Sem_Prag is -- Start of processing for Contains_Loop_Entry begin - Has_Loop_Entry := False; Traverse (Expr); return Has_Loop_Entry; end Contains_Loop_Entry; + -- Local variables + + Expr : Node_Id; + Newa : List_Id; + -- Start of processing for Assert begin @@ -11203,17 +10971,19 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Check); Expr := Get_Pragma_Arg (Arg1); - -- Special processing for Loop_Invariant or for other cases if - -- a Loop_Entry attribute is present. + -- Special processing for Loop_Invariant, Loop_Variant or for + -- other cases where a Loop_Entry attribute is present. If the + -- assertion pragma contains attribute Loop_Entry, ensure that + -- the related pragma is within a loop. if Prag_Id = Pragma_Loop_Invariant - or else Contains_Loop_Entry + or else Prag_Id = Pragma_Loop_Variant + or else Contains_Loop_Entry (Expr) then - -- Check restricted placement, must be within a loop - Check_Loop_Pragma_Placement; - -- Do preanalyze to deal with embedded Loop_Entry attribute + -- Perform preanalysis to deal with embedded Loop_Entry + -- attributes. Preanalyze_Assert_Expression (Expression (Arg1), Any_Boolean); end if; @@ -11240,6 +11010,11 @@ package body Sem_Prag is if Arg_Count > 1 then Check_Optional_Identifier (Arg2, Name_Message); + + -- Provide semantic annnotations for optional argument, for + -- ASIS use, before rewriting. + + Preanalyze_And_Resolve (Expression (Arg2), Standard_String); Append_To (Newa, New_Copy_Tree (Arg2)); end if; @@ -11276,17 +11051,18 @@ package body Sem_Prag is -- Type_Invariant | -- Type_Invariant'Class - -- ID_ASSERTION_KIND ::= Assert_And_Cut | - -- Assume | - -- Contract_Cases | - -- Debug | - -- Initial_Condition | - -- Loop_Invariant | - -- Loop_Variant | - -- Postcondition | - -- Precondition | - -- Predicate | - -- Refined_Post | + -- ID_ASSERTION_KIND ::= Assert_And_Cut | + -- Assume | + -- Contract_Cases | + -- Debug | + -- Default_Initial_Condition | + -- Initial_Condition | + -- Loop_Invariant | + -- Loop_Variant | + -- Postcondition | + -- Precondition | + -- Predicate | + -- Refined_Post | -- Statement_Assertions -- Note: The RM_ASSERTION_KIND list is language-defined, and the @@ -11487,130 +11263,74 @@ package body Sem_Prag is Analyze (N); end Attribute_Definition; - --------------- - -- AST_Entry -- - --------------- + ------------------------------------------------------------------ + -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- + ------------------------------------------------------------------ + + -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] ); + -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] ); + -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] ); + -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] ); - -- pragma AST_Entry (entry_IDENTIFIER); + -- FLAG ::= boolean_EXPRESSION - when Pragma_AST_Entry => AST_Entry : declare - Ent : Node_Id; + when Pragma_Async_Readers | + Pragma_Async_Writers | + Pragma_Effective_Reads | + Pragma_Effective_Writes => + Async_Effective : declare + Duplic : Node_Id; + Expr : Node_Id; + Obj : Node_Id; + Obj_Id : Entity_Id; begin GNAT_Pragma; - Check_VMS (N); - Check_Arg_Count (1); Check_No_Identifiers; + Check_At_Least_N_Arguments (1); + Check_At_Most_N_Arguments (2); Check_Arg_Is_Local_Name (Arg1); - Ent := Entity (Get_Pragma_Arg (Arg1)); + Error_Msg_Name_1 := Pname; - -- Note: the implementation of the AST_Entry pragma could handle - -- the entry family case fine, but for now we are consistent with - -- the DEC rules, and do not allow the pragma, which of course - -- has the effect of also forbidding the attribute. - - if Ekind (Ent) /= E_Entry then - Error_Pragma_Arg - ("pragma% argument must be simple entry name", Arg1); - - elsif Is_AST_Entry (Ent) then - Error_Pragma_Arg - ("duplicate % pragma for entry", Arg1); - - elsif Has_Homonym (Ent) then - Error_Pragma_Arg - ("pragma% argument cannot specify overloaded entry", Arg1); - - else - declare - FF : constant Entity_Id := First_Formal (Ent); - - begin - if Present (FF) then - if Present (Next_Formal (FF)) then - Error_Pragma_Arg - ("entry for pragma% can have only one argument", - Arg1); - - elsif Parameter_Mode (FF) /= E_In_Parameter then - Error_Pragma_Arg - ("entry parameter for pragma% must have mode IN", - Arg1); - end if; - end if; - end; - - Set_Is_AST_Entry (Ent); - end if; - end AST_Entry; - - ------------------------------------------------------------------ - -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes -- - ------------------------------------------------------------------ - - -- pragma Asynch_Readers ( object_LOCAL_NAME [, FLAG] ); - -- pragma Asynch_Writers ( object_LOCAL_NAME [, FLAG] ); - -- pragma Effective_Reads ( object_LOCAL_NAME [, FLAG] ); - -- pragma Effective_Writes ( object_LOCAL_NAME [, FLAG] ); - - -- FLAG ::= boolean_EXPRESSION - - when Pragma_Async_Readers | - Pragma_Async_Writers | - Pragma_Effective_Reads | - Pragma_Effective_Writes => - Async_Effective : declare - Duplic : Node_Id; - Obj_Id : Entity_Id; - - begin - GNAT_Pragma; - Check_No_Identifiers; - Check_At_Least_N_Arguments (1); - Check_At_Most_N_Arguments (2); - Check_Arg_Is_Local_Name (Arg1); - - Arg1 := Get_Pragma_Arg (Arg1); + Obj := Get_Pragma_Arg (Arg1); + Expr := Get_Pragma_Arg (Arg2); -- Perform minimal verification to ensure that the argument is at -- least a variable. Subsequent finer grained checks will be done -- at the end of the declarative region the contains the pragma. - if Is_Entity_Name (Arg1) and then Present (Entity (Arg1)) then - Obj_Id := Entity (Get_Pragma_Arg (Arg1)); + if Is_Entity_Name (Obj) + and then Present (Entity (Obj)) + and then Ekind (Entity (Obj)) = E_Variable + then + Obj_Id := Entity (Obj); - -- It is not efficient to examine preceding statements in order - -- to detect duplicate pragmas as Boolean aspects may appear + -- Detect a duplicate pragma. Note that it is not efficient to + -- examine preceding statements as Boolean aspects may appear -- anywhere between the related object declaration and its -- freeze point. As an alternative, inspect the contents of the -- variable contract. - if Ekind (Obj_Id) = E_Variable then - Duplic := Get_Pragma (Obj_Id, Prag_Id); + Duplic := Get_Pragma (Obj_Id, Prag_Id); - if Present (Duplic) then - Error_Msg_Name_1 := Pname; - Error_Msg_Sloc := Sloc (Duplic); - Error_Msg_N ("pragma % duplicates pragma declared #", N); + if Present (Duplic) then + Error_Msg_Sloc := Sloc (Duplic); + Error_Msg_N ("pragma % duplicates pragma declared #", N); - -- Chain the pragma on the contract for further processing. - -- This also aids in detecting duplicates. + -- No duplicate detected - else - Add_Contract_Item (N, Obj_Id); + else + if Present (Expr) then + Preanalyze_And_Resolve (Expr, Standard_Boolean); end if; - -- The minimum legality requirements have been met, do not - -- fall through to the error message. + -- Chain the pragma on the contract for further processing - return; + Add_Contract_Item (N, Obj_Id); end if; + else + Error_Pragma ("pragma % must apply to a volatile object"); end if; - - -- If we get here, then the pragma applies to a non-object - -- construct, issue a generic error (SPARK RM 7.1.3(2)). - - Error_Pragma ("pragma % must apply to a volatile object"); end Async_Effective; ------------------ @@ -11897,7 +11617,7 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, "max_size"); Arg := Get_Pragma_Arg (Arg1); - Check_Arg_Is_Static_Expression (Arg, Any_Integer); + Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer); Val := Expr_Value (Arg); @@ -12122,7 +11842,7 @@ package body Sem_Prag is GNAT_Pragma; Check_Valid_Configuration_Pragma; Check_Arg_Count (0); - Check_Float_Overflow := True; + Check_Float_Overflow := not Machine_Overflows_On_Target; ---------------- -- Check_Name -- @@ -12879,7 +12599,7 @@ package body Sem_Prag is -- Must be static - if not Is_Static_Expression (Arg) then + if not Is_OK_Static_Expression (Arg) then Flag_Non_Static_Expr ("main subprogram affinity is not static!", Arg); raise Pragma_Exit; @@ -13071,6 +12791,163 @@ package body Sem_Prag is Expression => Get_Pragma_Arg (Arg1))))); Analyze (N); + -------------------------------------- + -- Pragma_Default_Initial_Condition -- + -------------------------------------- + + -- pragma Pragma_Default_Initial_Condition + -- [ (null | boolean_EXPRESSION) ]; + + when Pragma_Default_Initial_Condition => Default_Init_Cond : declare + Discard : Boolean; + Stmt : Node_Id; + Typ : Entity_Id; + + begin + GNAT_Pragma; + Check_At_Most_N_Arguments (1); + + Stmt := Prev (N); + while Present (Stmt) loop + + -- Skip prior pragmas, but check for duplicates + + if Nkind (Stmt) = N_Pragma then + if Pragma_Name (Stmt) = Pname then + Error_Msg_Name_1 := Pname; + Error_Msg_Sloc := Sloc (Stmt); + Error_Msg_N ("pragma % duplicates pragma declared#", N); + end if; + + -- Skip internally generated code + + elsif not Comes_From_Source (Stmt) then + null; + + -- The associated private type [extension] has been found, stop + -- the search. + + elsif Nkind_In (Stmt, N_Private_Extension_Declaration, + N_Private_Type_Declaration) + then + Typ := Defining_Entity (Stmt); + exit; + + -- The pragma does not apply to a legal construct, issue an + -- error and stop the analysis. + + else + Pragma_Misplaced; + return; + end if; + + Stmt := Prev (Stmt); + end loop; + + Set_Has_Default_Init_Cond (Typ); + Set_Has_Inherited_Default_Init_Cond (Typ, False); + + -- Chain the pragma on the rep item chain for further processing + + Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); + end Default_Init_Cond; + + ---------------------------------- + -- Default_Scalar_Storage_Order -- + ---------------------------------- + + -- pragma Default_Scalar_Storage_Order + -- (High_Order_First | Low_Order_First); + + when Pragma_Default_Scalar_Storage_Order => DSSO : declare + Default : Character; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + + -- Default_Scalar_Storage_Order can appear as a configuration + -- pragma, or in a declarative part of a package spec. + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + Check_No_Identifiers; + Check_Arg_Is_One_Of + (Arg1, Name_High_Order_First, Name_Low_Order_First); + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + Default := Fold_Upper (Name_Buffer (1)); + + if not Support_Nondefault_SSO_On_Target + and then (Ttypes.Bytes_Big_Endian /= (Default = 'H')) + then + if Warn_On_Unrecognized_Pragma then + Error_Msg_N + ("non-default Scalar_Storage_Order not supported " + & "on target?g?", N); + Error_Msg_N + ("\pragma Default_Scalar_Storage_Order ignored?g?", N); + end if; + + -- Here set the specified default + + else + Opt.Default_SSO := Default; + end if; + end DSSO; + + -------------------------- + -- Default_Storage_Pool -- + -------------------------- + + -- pragma Default_Storage_Pool (storage_pool_NAME | null); + + when Pragma_Default_Storage_Pool => + Ada_2012_Pragma; + Check_Arg_Count (1); + + -- Default_Storage_Pool can appear as a configuration pragma, or + -- in a declarative part of a package spec. + + if not Is_Configuration_Pragma then + Check_Is_In_Decl_Part_Or_Package_Spec; + end if; + + -- Case of Default_Storage_Pool (null); + + if Nkind (Expression (Arg1)) = N_Null then + Analyze (Expression (Arg1)); + + -- This is an odd case, this is not really an expression, so + -- we don't have a type for it. So just set the type to Empty. + + Set_Etype (Expression (Arg1), Empty); + + -- Case of Default_Storage_Pool (storage_pool_NAME); + + else + -- If it's a configuration pragma, then the only allowed + -- argument is "null". + + if Is_Configuration_Pragma then + Error_Pragma_Arg ("NULL expected", Arg1); + end if; + + -- The expected type for a non-"null" argument is + -- Root_Storage_Pool'Class. + + Analyze_And_Resolve + (Get_Pragma_Arg (Arg1), + Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool))); + end if; + + -- Finally, record the pool name (or null). Freeze.Freeze_Entity + -- for an access type will use this information to set the + -- appropriate attributes of the access type. + + Default_Pool := Expression (Arg1); + ------------- -- Depends -- ------------- @@ -13166,79 +13043,6 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Detect_Blocking := True; - ---------------------------------- - -- Default_Scalar_Storage_Order -- - ---------------------------------- - - -- pragma Default_Scalar_Storage_Order - -- (High_Order_First | Low_Order_First); - - when Pragma_Default_Scalar_Storage_Order => - GNAT_Pragma; - Check_Arg_Count (1); - - -- Default_Scalar_Storage_Order can appear as a configuration - -- pragma, or in a declarative part of a package spec. - - if not Is_Configuration_Pragma then - Check_Is_In_Decl_Part_Or_Package_Spec; - end if; - - Check_No_Identifiers; - Check_Arg_Is_One_Of - (Arg1, Name_Low_Order_First, Name_High_Order_First); - - -------------------------- - -- Default_Storage_Pool -- - -------------------------- - - -- pragma Default_Storage_Pool (storage_pool_NAME | null); - - when Pragma_Default_Storage_Pool => - Ada_2012_Pragma; - Check_Arg_Count (1); - - -- Default_Storage_Pool can appear as a configuration pragma, or - -- in a declarative part of a package spec. - - if not Is_Configuration_Pragma then - Check_Is_In_Decl_Part_Or_Package_Spec; - end if; - - -- Case of Default_Storage_Pool (null); - - if Nkind (Expression (Arg1)) = N_Null then - Analyze (Expression (Arg1)); - - -- This is an odd case, this is not really an expression, so - -- we don't have a type for it. So just set the type to Empty. - - Set_Etype (Expression (Arg1), Empty); - - -- Case of Default_Storage_Pool (storage_pool_NAME); - - else - -- If it's a configuration pragma, then the only allowed - -- argument is "null". - - if Is_Configuration_Pragma then - Error_Pragma_Arg ("NULL expected", Arg1); - end if; - - -- The expected type for a non-"null" argument is - -- Root_Storage_Pool'Class. - - Analyze_And_Resolve - (Get_Pragma_Arg (Arg1), - Typ => Class_Wide_Type (RTE (RE_Root_Storage_Pool))); - end if; - - -- Finally, record the pool name (or null). Freeze.Freeze_Entity - -- for an access type will use this information to set the - -- appropriate attributes of the access type. - - Default_Pool := Expression (Arg1); - ------------------------------------ -- Disable_Atomic_Synchronization -- ------------------------------------ @@ -13754,48 +13558,6 @@ package body Sem_Prag is end if; end Export; - ---------------------- - -- Export_Exception -- - ---------------------- - - -- pragma Export_Exception ( - -- [Internal =>] LOCAL_NAME - -- [, [External =>] EXTERNAL_SYMBOL] - -- [, [Form =>] Ada | VMS] - -- [, [Code =>] static_integer_EXPRESSION]); - - when Pragma_Export_Exception => Export_Exception : declare - Args : Args_List (1 .. 4); - Names : constant Name_List (1 .. 4) := ( - Name_Internal, - Name_External, - Name_Form, - Name_Code); - - Internal : Node_Id renames Args (1); - External : Node_Id renames Args (2); - Form : Node_Id renames Args (3); - Code : Node_Id renames Args (4); - - begin - GNAT_Pragma; - - if Inside_A_Generic then - Error_Pragma ("pragma% cannot be used for generic entities"); - end if; - - Gather_Associations (Names, Args); - Process_Extended_Import_Export_Exception_Pragma ( - Arg_Internal => Internal, - Arg_External => External, - Arg_Form => Form, - Arg_Code => Code); - - if not Is_VMS_Exception (Entity (Internal)) then - Set_Exported (Entity (Internal), Internal); - end if; - end Export_Exception; - --------------------- -- Export_Function -- --------------------- @@ -13830,9 +13592,6 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Export_Function => Export_Function : declare Args : Args_List (1 .. 6); @@ -13894,9 +13653,6 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Export_Object => Export_Object : declare Args : Args_List (1 .. 3); @@ -13950,9 +13706,6 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Export_Procedure => Export_Procedure : declare Args : Args_List (1 .. 4); @@ -13991,10 +13744,10 @@ package body Sem_Prag is Check_Arg_Count (2); Check_Optional_Identifier (Arg1, Name_Value); - Check_Arg_Is_Static_Expression (Arg1, Any_Integer); + Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); Check_Optional_Identifier (Arg2, Name_Link_Name); - Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); ----------------------------- -- Export_Valued_Procedure -- @@ -14028,9 +13781,6 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Export_Valued_Procedure => Export_Valued_Procedure : declare @@ -14285,106 +14035,6 @@ package body Sem_Prag is end if; end Finalize_Storage; - -------------------------- - -- Float_Representation -- - -------------------------- - - -- pragma Float_Representation (FLOAT_REP[, float_type_LOCAL_NAME]); - - -- FLOAT_REP ::= VAX_Float | IEEE_Float - - when Pragma_Float_Representation => Float_Representation : declare - Argx : Node_Id; - Digs : Nat; - Ent : Entity_Id; - - begin - GNAT_Pragma; - - if Arg_Count = 1 then - Check_Valid_Configuration_Pragma; - else - Check_Arg_Count (2); - Check_Optional_Identifier (Arg2, Name_Entity); - Check_Arg_Is_Local_Name (Arg2); - end if; - - Check_No_Identifier (Arg1); - Check_Arg_Is_One_Of (Arg1, Name_VAX_Float, Name_IEEE_Float); - - if not OpenVMS_On_Target then - if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then - Error_Pragma - ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; - - return; - end if; - - -- One argument case - - if Arg_Count = 1 then - if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then - if Opt.Float_Format = 'I' then - Error_Pragma ("'I'E'E'E format previously specified"); - end if; - - Opt.Float_Format := 'V'; - - else - if Opt.Float_Format = 'V' then - Error_Pragma ("'V'A'X format previously specified"); - end if; - - Opt.Float_Format := 'I'; - end if; - - Set_Standard_Fpt_Formats; - - -- Two argument case - - else - Argx := Get_Pragma_Arg (Arg2); - - if not Is_Entity_Name (Argx) - or else not Is_Floating_Point_Type (Entity (Argx)) - then - Error_Pragma_Arg - ("second argument of% pragma must be floating-point type", - Arg2); - end if; - - Ent := Entity (Argx); - Digs := UI_To_Int (Digits_Value (Ent)); - - -- Two arguments, VAX_Float case - - if Chars (Get_Pragma_Arg (Arg1)) = Name_VAX_Float then - case Digs is - when 6 => Set_F_Float (Ent); - when 9 => Set_D_Float (Ent); - when 15 => Set_G_Float (Ent); - - when others => - Error_Pragma_Arg - ("wrong digits value, must be 6,9 or 15", Arg2); - end case; - - -- Two arguments, IEEE_Float case - - else - case Digs is - when 6 => Set_IEEE_Short (Ent); - when 15 => Set_IEEE_Long (Ent); - - when others => - Error_Pragma_Arg - ("wrong digits value, must be 6 or 15", Arg2); - end case; - end if; - end if; - end Float_Representation; - ------------ -- Global -- ------------ @@ -14466,10 +14116,8 @@ package body Sem_Prag is -- pragma Ident (static_string_EXPRESSION) - -- Note: pragma Comment shares this processing. Pragma Comment is - -- identical to Ident, except that the restriction of the argument to - -- 31 characters and the placement restrictions are not enforced for - -- pragma Comment. + -- Note: pragma Comment shares this processing. Pragma Ident is + -- identical in effect to pragma Commment. when Pragma_Ident | Pragma_Comment => Ident : declare Str : Node_Id; @@ -14478,16 +14126,9 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (1); Check_No_Identifiers; - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); Store_Note (N); - -- For pragma Ident, preserve DEC compatibility by requiring the - -- pragma to appear in a declarative part or package spec. - - if Prag_Id = Pragma_Ident then - Check_Is_In_Decl_Part_Or_Package_Spec; - end if; - Str := Expr_Value_S (Get_Pragma_Arg (Arg1)); declare @@ -14511,15 +14152,10 @@ package body Sem_Prag is if Present (CS) then - -- For Ident, we do not permit multiple instances + -- If we have multiple instances, concatenate them, but + -- not in ASIS, where we want the original tree. - if Prag_Id = Pragma_Ident then - Error_Pragma ("duplicate% pragma not permitted"); - - -- For Comment, we concatenate the string, unless we want - -- to preserve the tree structure for ASIS. - - elsif not ASIS_Mode then + if not ASIS_Mode then Start_String (Strval (CS)); Store_String_Char (' '); Store_String_Chars (Strval (Str)); @@ -14527,25 +14163,6 @@ package body Sem_Prag is end if; else - -- In VMS, the effect of IDENT is achieved by passing - -- --identification=name as a --for-linker switch. - - if OpenVMS_On_Target then - Start_String; - Store_String_Chars - ("--for-linker=--identification="); - String_To_Name_Buffer (Strval (Str)); - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - - -- Only the last processed IDENT is saved. The main - -- purpose is so an IDENT associated with a main - -- procedure will be used in preference to an IDENT - -- associated with a with'd package. - - Replace_Linker_Option_String - (End_String, "--for-linker=--identification="); - end if; - Set_Ident_String (Current_Sem_Unit, Str); end if; @@ -14555,15 +14172,6 @@ package body Sem_Prag is elsif Nkind (GP) = N_Subunit then null; - - -- Otherwise we have a misplaced pragma Ident, but we ignore - -- this if we are in an instantiation, since it comes from - -- a generic, and has no relevance to the instantiation. - - elsif Prag_Id = Pragma_Ident then - if Instantiation_Location (Loc) = No_Location then - Error_Pragma ("pragma% only allowed at outer level"); - end if; end if; end; end Ident; @@ -14742,49 +14350,6 @@ package body Sem_Prag is Check_At_Most_N_Arguments (4); Process_Import_Or_Interface; - ---------------------- - -- Import_Exception -- - ---------------------- - - -- pragma Import_Exception ( - -- [Internal =>] LOCAL_NAME - -- [, [External =>] EXTERNAL_SYMBOL] - -- [, [Form =>] Ada | VMS] - -- [, [Code =>] static_integer_EXPRESSION]); - - when Pragma_Import_Exception => Import_Exception : declare - Args : Args_List (1 .. 4); - Names : constant Name_List (1 .. 4) := ( - Name_Internal, - Name_External, - Name_Form, - Name_Code); - - Internal : Node_Id renames Args (1); - External : Node_Id renames Args (2); - Form : Node_Id renames Args (3); - Code : Node_Id renames Args (4); - - begin - GNAT_Pragma; - Gather_Associations (Names, Args); - - if Present (External) and then Present (Code) then - Error_Pragma - ("cannot give both External and Code options for pragma%"); - end if; - - Process_Extended_Import_Export_Exception_Pragma ( - Arg_Internal => Internal, - Arg_External => External, - Arg_Form => Form, - Arg_Code => Code); - - if not Is_VMS_Exception (Entity (Internal)) then - Set_Imported (Entity (Internal)); - end if; - end Import_Exception; - --------------------- -- Import_Function -- --------------------- @@ -14795,8 +14360,7 @@ package body Sem_Prag is -- [, [Parameter_Types =>] (PARAMETER_TYPES)] -- [, [Result_Type =>] SUBTYPE_MARK] -- [, [Mechanism =>] MECHANISM] - -- [, [Result_Mechanism =>] MECHANISM_NAME] - -- [, [First_Optional_Parameter =>] IDENTIFIER]); + -- [, [Result_Mechanism =>] MECHANISM_NAME]); -- EXTERNAL_SYMBOL ::= -- IDENTIFIER @@ -14820,20 +14384,16 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Import_Function => Import_Function : declare - Args : Args_List (1 .. 7); - Names : constant Name_List (1 .. 7) := ( + Args : Args_List (1 .. 6); + Names : constant Name_List (1 .. 6) := ( Name_Internal, Name_External, Name_Parameter_Types, Name_Result_Type, Name_Mechanism, - Name_Result_Mechanism, - Name_First_Optional_Parameter); + Name_Result_Mechanism); Internal : Node_Id renames Args (1); External : Node_Id renames Args (2); @@ -14841,7 +14401,6 @@ package body Sem_Prag is Result_Type : Node_Id renames Args (4); Mechanism : Node_Id renames Args (5); Result_Mechanism : Node_Id renames Args (6); - First_Optional_Parameter : Node_Id renames Args (7); begin GNAT_Pragma; @@ -14852,8 +14411,7 @@ package body Sem_Prag is Arg_Parameter_Types => Parameter_Types, Arg_Result_Type => Result_Type, Arg_Mechanism => Mechanism, - Arg_Result_Mechanism => Result_Mechanism, - Arg_First_Optional_Parameter => First_Optional_Parameter); + Arg_Result_Mechanism => Result_Mechanism); end Import_Function; ------------------- @@ -14897,8 +14455,7 @@ package body Sem_Prag is -- [Internal =>] LOCAL_NAME -- [, [External =>] EXTERNAL_SYMBOL] -- [, [Parameter_Types =>] (PARAMETER_TYPES)] - -- [, [Mechanism =>] MECHANISM] - -- [, [First_Optional_Parameter =>] IDENTIFIER]); + -- [, [Mechanism =>] MECHANISM]); -- EXTERNAL_SYMBOL ::= -- IDENTIFIER @@ -14922,24 +14479,19 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Import_Procedure => Import_Procedure : declare - Args : Args_List (1 .. 5); - Names : constant Name_List (1 .. 5) := ( + Args : Args_List (1 .. 4); + Names : constant Name_List (1 .. 4) := ( Name_Internal, Name_External, Name_Parameter_Types, - Name_Mechanism, - Name_First_Optional_Parameter); + Name_Mechanism); Internal : Node_Id renames Args (1); External : Node_Id renames Args (2); Parameter_Types : Node_Id renames Args (3); Mechanism : Node_Id renames Args (4); - First_Optional_Parameter : Node_Id renames Args (5); begin GNAT_Pragma; @@ -14948,8 +14500,7 @@ package body Sem_Prag is Arg_Internal => Internal, Arg_External => External, Arg_Parameter_Types => Parameter_Types, - Arg_Mechanism => Mechanism, - Arg_First_Optional_Parameter => First_Optional_Parameter); + Arg_Mechanism => Mechanism); end Import_Procedure; ----------------------------- @@ -14960,8 +14511,7 @@ package body Sem_Prag is -- [Internal =>] LOCAL_NAME -- [, [External =>] EXTERNAL_SYMBOL] -- [, [Parameter_Types =>] (PARAMETER_TYPES)] - -- [, [Mechanism =>] MECHANISM] - -- [, [First_Optional_Parameter =>] IDENTIFIER]); + -- [, [Mechanism =>] MECHANISM]); -- EXTERNAL_SYMBOL ::= -- IDENTIFIER @@ -14985,25 +14535,20 @@ package body Sem_Prag is -- MECHANISM_NAME ::= -- Value -- | Reference - -- | Descriptor [([Class =>] CLASS_NAME)] - - -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca when Pragma_Import_Valued_Procedure => Import_Valued_Procedure : declare - Args : Args_List (1 .. 5); - Names : constant Name_List (1 .. 5) := ( + Args : Args_List (1 .. 4); + Names : constant Name_List (1 .. 4) := ( Name_Internal, Name_External, Name_Parameter_Types, - Name_Mechanism, - Name_First_Optional_Parameter); + Name_Mechanism); Internal : Node_Id renames Args (1); External : Node_Id renames Args (2); Parameter_Types : Node_Id renames Args (3); Mechanism : Node_Id renames Args (4); - First_Optional_Parameter : Node_Id renames Args (5); begin GNAT_Pragma; @@ -15012,8 +14557,7 @@ package body Sem_Prag is Arg_Internal => Internal, Arg_External => External, Arg_Parameter_Types => Parameter_Types, - Arg_Mechanism => Mechanism, - Arg_First_Optional_Parameter => First_Optional_Parameter); + Arg_Mechanism => Mechanism); end Import_Valued_Procedure; ----------------- @@ -15353,10 +14897,15 @@ package body Sem_Prag is when Pragma_Inline_Always => GNAT_Pragma; - -- Pragma always active unless in CodePeer or GNATprove mode, - -- since this causes walk order issues. + -- Pragma always active unless in CodePeer mode. It is disabled + -- in CodePeer mode because inlining is not helpful, and enabling + -- if caused walk order issues. - if not (CodePeer_Mode or GNATprove_Mode) then + -- Historical note: this pragma used to be disabled in GNATprove + -- mode as well, but that was odd since walk order should not be + -- an issue in that case. + + if not CodePeer_Mode then Process_Inline (Enabled); end if; @@ -15380,23 +14929,6 @@ package body Sem_Prag is Arg : Node_Id; Exp : Node_Id; - procedure ip; - -- A dummy procedure called when pragma Inspection_Point is - -- analyzed. This is just to help debugging the front end. If - -- a pragma Inspection_Point is added to a source program, then - -- breaking on ip will get you to that point in the program. - - -------- - -- ip -- - -------- - - procedure ip is - begin - null; - end ip; - - -- Start of processing for Inspection_Point - begin ip; @@ -15700,7 +15232,7 @@ package body Sem_Prag is -- expression of type Ada.Interrupts.Interrupt_ID. else - Check_Arg_Is_Static_Expression (Arg1, Any_Integer); + Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer); Int_Val := Expr_Value (Arg1X); if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) @@ -15773,10 +15305,7 @@ package body Sem_Prag is when Pragma_Invariant => Invariant : declare Type_Id : Node_Id; Typ : Entity_Id; - PDecl : Node_Id; - Discard : Boolean; - pragma Unreferenced (Discard); begin GNAT_Pragma; @@ -15787,7 +15316,7 @@ package body Sem_Prag is if Arg_Count = 3 then Check_Optional_Identifier (Arg3, Name_Message); - Check_Arg_Is_Static_Expression (Arg3, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String); end if; Check_Arg_Is_Local_Name (Arg1); @@ -15832,10 +15361,8 @@ package body Sem_Prag is -- procedure declaration, so that calls to it can be generated -- before the body is built (e.g. within an expression function). - PDecl := Build_Invariant_Procedure_Declaration (Typ); - - Insert_After (N, PDecl); - Analyze (PDecl); + Insert_After_And_Analyze + (N, Build_Invariant_Procedure_Declaration (Typ)); if Class_Present (N) then Set_Has_Inheritable_Invariants (Typ); @@ -16256,12 +15783,12 @@ package body Sem_Prag is Check_At_Least_N_Arguments (1); Check_No_Identifiers; Check_Is_In_Decl_Part_Or_Package_Spec; - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); Start_String; Arg := Arg1; while Present (Arg) loop - Check_Arg_Is_Static_Expression (Arg, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); -- Store argument, converting sequences of spaces to a -- single null character (this is one of the differences @@ -16336,7 +15863,7 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Target); Check_Arg_Is_Library_Level_Local_Name (Arg1); - Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); -- The only processing required is to link this item on to the -- list of rep items for the given entity. This is accomplished @@ -16409,12 +15936,12 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); Check_Is_In_Decl_Part_Or_Package_Spec; - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1)))); Arg := Arg2; while Present (Arg) loop - Check_Arg_Is_Static_Expression (Arg, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg, Standard_String); Store_String_Char (ASCII.NUL); Store_String_Chars (Strval (Expr_Value_S (Get_Pragma_Arg (Arg)))); @@ -16447,7 +15974,7 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Section); Check_Arg_Is_Library_Level_Local_Name (Arg1); - Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); -- Check kind of entity @@ -16576,91 +16103,32 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; 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'; - end case; - - if Locking_Policy /= ' ' - and then Locking_Policy /= LP - then - Error_Msg_Sloc := Locking_Policy_Sloc; - Error_Pragma ("locking policy incompatible with policy#"); - - -- Set new policy, but always preserve System_Location since we - -- like the error message with the run time name. - - else - Locking_Policy := LP; - - if Locking_Policy_Sloc /= System_Location then - Locking_Policy_Sloc := Loc; - end if; - end if; - end; - - ---------------- - -- Long_Float -- - ---------------- - - -- pragma Long_Float (D_Float | G_Float); - - when Pragma_Long_Float => Long_Float : declare - begin - GNAT_Pragma; - Check_Valid_Configuration_Pragma; - Check_Arg_Count (1); - Check_No_Identifier (Arg1); - Check_Arg_Is_One_Of (Arg1, Name_D_Float, Name_G_Float); - - if not OpenVMS_On_Target then - Error_Pragma ("??pragma% ignored (applies only to Open'V'M'S)"); - end if; - - -- D_Float case - - if Chars (Get_Pragma_Arg (Arg1)) = Name_D_Float then - if Opt.Float_Format_Long = 'G' then - Error_Pragma_Arg - ("G_Float previously specified", Arg1); - - elsif Current_Sem_Unit /= Main_Unit - and then Opt.Float_Format_Long /= 'D' - then - Error_Pragma_Arg - ("main unit not compiled with pragma Long_Float (D_Float)", - "\pragma% must be used consistently for whole partition", - Arg1); - - else - Opt.Float_Format_Long := 'D'; - end if; + case LP_Val is + when Name_Ceiling_Locking => + LP := 'C'; + when Name_Inheritance_Locking => + LP := 'I'; + when Name_Concurrent_Readers_Locking => + LP := 'R'; + end case; - -- G_Float case (this is the default, does not need overriding) + if Locking_Policy /= ' ' + and then Locking_Policy /= LP + then + Error_Msg_Sloc := Locking_Policy_Sloc; + Error_Pragma ("locking policy incompatible with policy#"); - else - if Opt.Float_Format_Long = 'D' then - Error_Pragma ("D_Float previously specified"); + -- Set new policy, but always preserve System_Location since we + -- like the error message with the run time name. - elsif Current_Sem_Unit /= Main_Unit - and then Opt.Float_Format_Long /= 'G' - then - Error_Pragma_Arg - ("main unit not compiled with pragma Long_Float (G_Float)", - "\pragma% must be used consistently for whole partition", - Arg1); + else + Locking_Policy := LP; - else - Opt.Float_Format_Long := 'G'; + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; end if; end if; - - Set_Standard_Fpt_Formats; - end Long_Float; + end; ------------------- -- Loop_Optimize -- @@ -16682,7 +16150,10 @@ package body Sem_Prag is Hint := First (Pragma_Argument_Associations (N)); while Present (Hint) loop Check_Arg_Is_One_Of (Hint, Name_Ivdep, - Name_No_Unroll, Name_Unroll, Name_No_Vector, Name_Vector); + Name_No_Unroll, + Name_Unroll, + Name_No_Vector, + Name_Vector); Next (Hint); end loop; @@ -16743,7 +16214,7 @@ package body Sem_Prag is if Arg_Count = 3 then Check_Optional_Identifier (Arg3, Name_Info); - Check_Arg_Is_Static_Expression (Arg3); + Check_Arg_Is_OK_Static_Expression (Arg3); else Check_Arg_Count (2); end if; @@ -16751,7 +16222,7 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Entity); Check_Optional_Identifier (Arg2, Name_Attribute_Name); Check_Arg_Is_Local_Name (Arg1); - Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String); Def_Id := Entity (Get_Pragma_Arg (Arg1)); if Is_Access_Type (Def_Id) then @@ -16803,12 +16274,12 @@ package body Sem_Prag is for J in 1 .. 2 loop if Present (Args (J)) then - Check_Arg_Is_Static_Expression (Args (J), Any_Integer); + Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); end if; end loop; if Present (Args (3)) then - Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean); + Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean); end if; Nod := Next (N); @@ -16849,7 +16320,7 @@ package body Sem_Prag is for J in 1 .. 2 loop if Present (Args (J)) then - Check_Arg_Is_Static_Expression (Args (J), Any_Integer); + Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer); end if; end loop; @@ -16900,6 +16371,51 @@ package body Sem_Prag is GNAT_Pragma; Pragma_Misplaced; + ----------------------------- + -- No_Elaboration_Code_All -- + ----------------------------- + + -- pragma No_Elaboration_Code_All; + + when Pragma_No_Elaboration_Code_All => NECA : declare + begin + GNAT_Pragma; + Check_Valid_Library_Unit_Pragma; + + if Nkind (N) = N_Null_Statement then + return; + end if; + + -- Must appear for a spec + + if not Nkind_In (Unit (Cunit (Current_Sem_Unit)), + N_Package_Declaration, + N_Subprogram_Declaration) + then + Error_Pragma + (Fix_Error + ("pragma% can only occur for package " + & "or subprogram spec")); + end if; + + -- Set flag in unit table + + Set_No_Elab_Code_All (Current_Sem_Unit); + + -- Set restriction No_Elaboration_Code, including adding it to the + -- set of configuration restrictions so it will apply to all units + -- in the extended main source. + + Set_Restriction (No_Elaboration_Code, N); + Add_To_Config_Boolean_Restrictions (No_Elaboration_Code); + + -- If in main extended unit, activate transitive with test + + if In_Extended_Main_Source_Unit (N) then + Opt.No_Elab_Code_All_Pragma := N; + end if; + end NECA; + --------------- -- No_Inline -- --------------- @@ -17143,7 +16659,7 @@ package body Sem_Prag is -- Deal with static string argument - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); S := Strval (Get_Pragma_Arg (Arg1)); for J in 1 .. String_Length (S) loop @@ -18168,9 +17684,7 @@ package body Sem_Prag is when Pragma_Predicate => Predicate : declare Type_Id : Node_Id; Typ : Entity_Id; - Discard : Boolean; - pragma Unreferenced (Discard); begin GNAT_Pragma; @@ -18272,7 +17786,7 @@ package body Sem_Prag is -- Must be static - if not Is_Static_Expression (Arg) then + if not Is_OK_Static_Expression (Arg) then Flag_Non_Static_Expr ("main subprogram priority is not static!", Arg); raise Pragma_Exit; @@ -18309,9 +17823,9 @@ package body Sem_Prag is -- supported profile) to make sure that one of these packages -- is implicitly with'ed, since we need to have the tasking -- run time active for the pragma Priority to have any effect. - -- Previously with with'ed the package System.Tasking, but - -- this package does not trigger the required initialization - -- of the run-time library. + -- Previously we with'ed the package System.Tasking, but this + -- package does not trigger the required initialization of the + -- run-time library. declare Discard : Entity_Id; @@ -18336,7 +17850,7 @@ package body Sem_Prag is Preanalyze_Spec_Expression (Arg, RTE (RE_Any_Priority)); - if not Is_Static_Expression (Arg) then + if not Is_OK_Static_Expression (Arg) then Check_Restriction (Static_Priorities, Arg); end if; @@ -18383,11 +17897,11 @@ package body Sem_Prag is DP := Fold_Upper (Name_Buffer (1)); Lower_Bound := Get_Pragma_Arg (Arg2); - Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer); + Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer); Lower_Val := Expr_Value (Lower_Bound); Upper_Bound := Get_Pragma_Arg (Arg3); - Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer); + Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer); Upper_Val := Expr_Value (Upper_Bound); -- It is not allowed to use Task_Dispatching_Policy and @@ -18717,37 +18231,24 @@ package body Sem_Prag is Def_Id : Entity_Id; - procedure Check_Too_Long (Arg : Node_Id); - -- Posts message if the argument is an identifier with more - -- than 31 characters, or a string literal with more than - -- 31 characters, and we are operating under VMS - - -------------------- - -- Check_Too_Long -- - -------------------- + procedure Check_Arg (Arg : Node_Id); + -- Checks that argument is either a string literal or an + -- identifier, and posts error message if not. - procedure Check_Too_Long (Arg : Node_Id) is - X : constant Node_Id := Original_Node (Arg); + --------------- + -- Check_Arg -- + --------------- + procedure Check_Arg (Arg : Node_Id) is begin - if not Nkind_In (X, N_String_Literal, N_Identifier) then + if not Nkind_In (Original_Node (Arg), + N_String_Literal, + N_Identifier) + then Error_Pragma_Arg ("inappropriate argument for pragma %", Arg); end if; - - if OpenVMS_On_Target then - if (Nkind (X) = N_String_Literal - and then String_Length (Strval (X)) > 31) - or else - (Nkind (X) = N_Identifier - and then Length_Of_Name (Chars (X)) > 31) - then - Error_Pragma_Arg - ("argument for pragma % is longer than 31 characters", - Arg); - end if; - end if; - end Check_Too_Long; + end Check_Arg; -- Start of processing for Common_Object/Psect_Object @@ -18763,7 +18264,7 @@ package body Sem_Prag is ("pragma% must designate an object", Internal); end if; - Check_Too_Long (Internal); + Check_Arg (Internal); if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then Error_Pragma_Arg @@ -18816,12 +18317,11 @@ package body Sem_Prag is end if; if Present (Size) then - Check_Too_Long (Size); + Check_Arg (Size); end if; if Present (External) then Check_Arg_Is_External_Name (External); - Check_Too_Long (External); end if; -- If all error tests pass, link pragma on to the rep item chain @@ -19453,11 +18953,12 @@ package body Sem_Prag is -- pragma Short_Descriptors; + -- Recognize and validate, but otherwise ignore + when Pragma_Short_Descriptors => GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Short_Descriptors := True; ------------------------------ -- Simple_Storage_Pool_Type -- @@ -19620,13 +19121,6 @@ package body Sem_Prag is -- pragma SPARK_Mode [(On | Off)]; when Pragma_SPARK_Mode => Do_SPARK_Mode : declare - Body_Id : Entity_Id; - Context : Node_Id; - Mode : Name_Id; - Mode_Id : SPARK_Mode_Type; - Spec_Id : Entity_Id; - Stmt : Node_Id; - procedure Check_Pragma_Conformance (Context_Pragma : Node_Id; Entity_Pragma : Node_Id; @@ -19667,7 +19161,7 @@ package body Sem_Prag is -- New mode less restrictive than the established mode if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off - and then Mode_Id = On + and then Get_SPARK_Mode_From_Pragma (N) = On then Error_Msg_N ("cannot change SPARK_Mode from Off to On", Arg1); @@ -19680,7 +19174,7 @@ package body Sem_Prag is if Present (Entity) then if Present (Entity_Pragma) then if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off - and then Mode_Id = On + and then Get_SPARK_Mode_From_Pragma (N) = On then Error_Msg_N ("incorrect use of SPARK_Mode", Arg1); Error_Msg_Sloc := Sloc (Entity_Pragma); @@ -19728,9 +19222,28 @@ package body Sem_Prag is end if; end Check_Library_Level_Entity; + -- Local variables + + Body_Id : Entity_Id; + Context : Node_Id; + Mode : Name_Id; + Mode_Id : SPARK_Mode_Type; + Spec_Id : Entity_Id; + Stmt : Node_Id; + -- Start of processing for Do_SPARK_Mode begin + -- When a SPARK_Mode pragma appears inside an instantiation whose + -- enclosing context has SPARK_Mode set to "off", the pragma has + -- no semantic effect. + + if Ignore_Pragma_SPARK_Mode then + Rewrite (N, Make_Null_Statement (Loc)); + Analyze (N); + return; + end if; + GNAT_Pragma; Check_No_Identifiers; Check_At_Most_N_Arguments (1); @@ -19747,15 +19260,9 @@ package body Sem_Prag is Mode_Id := Get_SPARK_Mode_Type (Mode); Context := Parent (N); - -- Packages and subprograms declared in a generic unit cannot be - -- subject to the pragma. - - if Inside_A_Generic then - Error_Pragma ("incorrect placement of pragma% in a generic"); - -- The pragma appears in a configuration pragmas file - elsif No (Context) then + if No (Context) then Check_Valid_Configuration_Pragma; if Present (SPARK_Mode_Pragma) then @@ -19767,29 +19274,23 @@ package body Sem_Prag is SPARK_Mode_Pragma := N; SPARK_Mode := Mode_Id; - -- When the pragma is placed before the declaration of a unit, it - -- configures the whole unit. - - elsif Nkind (Context) = N_Compilation_Unit then - Check_Valid_Configuration_Pragma; + -- The pragma acts as a configuration pragma in a compilation unit - if Nkind (Unit (Context)) in N_Generic_Declaration - or else (Present (Library_Unit (Context)) - and then Nkind (Unit (Library_Unit (Context))) in - N_Generic_Declaration) - then - Error_Pragma ("incorrect placement of pragma% in a generic"); - end if; + -- pragma SPARK_Mode ...; + -- package Pack is ...; + elsif Nkind (Context) = N_Compilation_Unit + and then List_Containing (N) = Context_Items (Context) + then + Check_Valid_Configuration_Pragma; SPARK_Mode_Pragma := N; SPARK_Mode := Mode_Id; - -- The pragma applies to a [library unit] subprogram or package + -- Otherwise the placement of the pragma within the tree dictates + -- its associated construct. Inspect the declarative list where + -- the pragma resides to find a potential construct. else - -- Verify the placement of the pragma with respect to package - -- or subprogram declarations and detect duplicates. - Stmt := Prev (N); while Present (Stmt) loop @@ -19803,18 +19304,17 @@ package body Sem_Prag is raise Pragma_Exit; end if; - -- Skip internally generated code - - elsif not Comes_From_Source (Stmt) then - null; - - elsif Nkind (Stmt) in N_Generic_Declaration then - Error_Pragma - ("incorrect placement of pragma% on a generic"); + -- The pragma applies to a [generic] subprogram declaration. + -- Note that this case covers an internally generated spec + -- for a stand alone body. - -- The pragma applies to a package declaration + -- [generic] + -- procedure Proc ...; + -- pragma SPARK_Mode ..; - elsif Nkind (Stmt) = N_Package_Declaration then + elsif Nkind_In (Stmt, N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + then Spec_Id := Defining_Entity (Stmt); Check_Library_Level_Entity (Spec_Id); Check_Pragma_Conformance @@ -19822,90 +19322,49 @@ package body Sem_Prag is Entity_Pragma => Empty, Entity => Empty); - Set_SPARK_Pragma (Spec_Id, N); - Set_SPARK_Pragma_Inherited (Spec_Id, False); - Set_SPARK_Aux_Pragma (Spec_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); + Set_SPARK_Pragma (Spec_Id, N); + Set_SPARK_Pragma_Inherited (Spec_Id, False); return; - -- The pragma applies to a subprogram declaration - - elsif Nkind (Stmt) = N_Subprogram_Declaration then - Spec_Id := Defining_Entity (Stmt); - Check_Library_Level_Entity (Spec_Id); - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Spec_Id), - Entity_Pragma => Empty, - Entity => Empty); + -- Skip internally generated code - Set_SPARK_Pragma (Spec_Id, N); - Set_SPARK_Pragma_Inherited (Spec_Id, False); - return; + elsif not Comes_From_Source (Stmt) then + null; - -- The pragma does not apply to a legal construct, issue an - -- error and stop the analysis. + -- Otherwise the pragma does not apply to a legal construct + -- or it does not appear at the top of a declarative or a + -- statement list. Issue an error and stop the analysis. else Pragma_Misplaced; exit; end if; - Stmt := Prev (Stmt); + Prev (Stmt); end loop; - -- Handle all cases where the pragma is actually an aspect and - -- applies to a library-level package spec, body or subprogram. - - -- function F ... with SPARK_Mode => ...; - -- package P with SPARK_Mode => ...; - -- package body P with SPARK_Mode => ... is + -- The pragma applies to a package or a subprogram that acts as + -- a compilation unit. - -- The following circuitry simply prepares the proper context - -- for the general pragma processing mechanism below. + -- procedure Proc ...; + -- pragma SPARK_Mode ...; if Nkind (Context) = N_Compilation_Unit_Aux then Context := Unit (Parent (Context)); - - if Nkind_In (Context, N_Package_Declaration, - N_Subprogram_Declaration) - then - Context := Specification (Context); - end if; end if; - -- The pragma is at the top level of a package spec - - -- package P is - -- pragma SPARK_Mode; - - -- or - - -- package P is - -- ... - -- private - -- pragma SPARK_Mode; + -- The pragma appears within package declarations if Nkind (Context) = N_Package_Specification then Spec_Id := Defining_Entity (Context); + Check_Library_Level_Entity (Spec_Id); - -- Pragma applies to private part - - if List_Containing (N) = Private_Declarations (Context) then - Check_Library_Level_Entity (Spec_Id); - Check_Pragma_Conformance - (Context_Pragma => Empty, - Entity_Pragma => SPARK_Pragma (Spec_Id), - Entity => Spec_Id); - SPARK_Mode_Pragma := N; - SPARK_Mode := Mode_Id; - - Set_SPARK_Aux_Pragma (Spec_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); + -- The pragma is at the top of the visible declarations - -- Pragma applies to public part + -- package Pack is + -- pragma SPARK_Mode ...; - else - Check_Library_Level_Entity (Spec_Id); + if List_Containing (N) = Visible_Declarations (Context) then Check_Pragma_Conformance (Context_Pragma => SPARK_Pragma (Spec_Id), Entity_Pragma => Empty, @@ -19917,28 +19376,29 @@ package body Sem_Prag is Set_SPARK_Pragma_Inherited (Spec_Id, False); Set_SPARK_Aux_Pragma (Spec_Id, N); Set_SPARK_Aux_Pragma_Inherited (Spec_Id, True); - end if; - -- The pragma appears as an aspect on a subprogram. + -- The pragma is at the top of the private declarations - -- function F ... with SPARK_Mode => ...; + -- package Pack is + -- private + -- pragma SPARK_Mode ...; - elsif Nkind_In (Context, N_Function_Specification, - N_Procedure_Specification) - then - Spec_Id := Defining_Entity (Context); - Check_Library_Level_Entity (Spec_Id); - Check_Pragma_Conformance - (Context_Pragma => SPARK_Pragma (Spec_Id), - Entity_Pragma => Empty, - Entity => Empty); - Set_SPARK_Pragma (Spec_Id, N); - Set_SPARK_Pragma_Inherited (Spec_Id, False); + else + Check_Pragma_Conformance + (Context_Pragma => Empty, + Entity_Pragma => SPARK_Pragma (Spec_Id), + Entity => Spec_Id); + SPARK_Mode_Pragma := N; + SPARK_Mode := Mode_Id; + + Set_SPARK_Aux_Pragma (Spec_Id, N); + Set_SPARK_Aux_Pragma_Inherited (Spec_Id, False); + end if; - -- Pragma is immediately within a package body + -- The pragma appears at the top of package body declarations - -- package body P is - -- pragma SPARK_Mode; + -- package body Pack is + -- pragma SPARK_Mode ...; elsif Nkind (Context) = N_Package_Body then Spec_Id := Corresponding_Spec (Context); @@ -19956,22 +19416,79 @@ package body Sem_Prag is Set_SPARK_Aux_Pragma (Body_Id, N); Set_SPARK_Aux_Pragma_Inherited (Body_Id, True); - -- Pragma is immediately within a subprogram body + -- The pragma appears at the top of package body statements + + -- package body Pack is + -- begin + -- pragma SPARK_Mode; + + elsif Nkind (Context) = N_Handled_Sequence_Of_Statements + and then Nkind (Parent (Context)) = N_Package_Body + then + Context := Parent (Context); + Spec_Id := Corresponding_Spec (Context); + Body_Id := Defining_Entity (Context); + Check_Library_Level_Entity (Body_Id); + Check_Pragma_Conformance + (Context_Pragma => Empty, + Entity_Pragma => SPARK_Pragma (Body_Id), + Entity => Body_Id); + SPARK_Mode_Pragma := N; + SPARK_Mode := Mode_Id; + + Set_SPARK_Aux_Pragma (Body_Id, N); + Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); + + -- The pragma appeared as an aspect of a [generic] subprogram + -- declaration that acts as a compilation unit. + + -- [generic] + -- procedure Proc ...; + -- pragma SPARK_Mode ...; + + elsif Nkind_In (Context, N_Generic_Subprogram_Declaration, + N_Subprogram_Declaration) + then + Spec_Id := Defining_Entity (Context); + Check_Library_Level_Entity (Spec_Id); + Check_Pragma_Conformance + (Context_Pragma => SPARK_Pragma (Spec_Id), + Entity_Pragma => Empty, + Entity => Empty); + + Set_SPARK_Pragma (Spec_Id, N); + Set_SPARK_Pragma_Inherited (Spec_Id, False); - -- function F ... is + -- The pragma appears at the top of subprogram body + -- declarations. + + -- procedure Proc ... is -- pragma SPARK_Mode; elsif Nkind (Context) = N_Subprogram_Body then Spec_Id := Corresponding_Spec (Context); Context := Specification (Context); Body_Id := Defining_Entity (Context); + + -- Ignore pragma when applied to the special body created + -- for inlining, recognized by its internal name _Parent. + + if Chars (Body_Id) = Name_uParent then + return; + end if; + Check_Library_Level_Entity (Body_Id); + -- The body is a completion of a previous declaration + if Present (Spec_Id) then Check_Pragma_Conformance (Context_Pragma => SPARK_Pragma (Body_Id), Entity_Pragma => SPARK_Pragma (Spec_Id), Entity => Spec_Id); + + -- The body acts as spec + else Check_Pragma_Conformance (Context_Pragma => SPARK_Pragma (Body_Id), @@ -19985,29 +19502,6 @@ package body Sem_Prag is Set_SPARK_Pragma (Body_Id, N); Set_SPARK_Pragma_Inherited (Body_Id, False); - -- The pragma applies to the statements of a package body - - -- package body P is - -- begin - -- pragma SPARK_Mode; - - elsif Nkind (Context) = N_Handled_Sequence_Of_Statements - and then Nkind (Parent (Context)) = N_Package_Body - then - Context := Parent (Context); - Spec_Id := Corresponding_Spec (Context); - Body_Id := Defining_Entity (Context); - Check_Library_Level_Entity (Body_Id); - Check_Pragma_Conformance - (Context_Pragma => Empty, - Entity_Pragma => SPARK_Pragma (Body_Id), - Entity => Body_Id); - SPARK_Mode_Pragma := N; - SPARK_Mode := Mode_Id; - - Set_SPARK_Aux_Pragma (Body_Id, N); - Set_SPARK_Aux_Pragma_Inherited (Body_Id, False); - -- The pragma does not apply to a legal construct, issue error else @@ -20054,7 +19548,7 @@ package body Sem_Prag is Arg := Get_Pragma_Arg (Arg1); Preanalyze_Spec_Expression (Arg, Any_Integer); - if not Is_Static_Expression (Arg) then + if not Is_OK_Static_Expression (Arg) then Check_Restriction (Static_Storage_Size, Arg); end if; @@ -20330,7 +19824,7 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (1); Check_Optional_Identifier (Arg1, Name_Subtitle); - Check_Arg_Is_Static_Expression (Arg1, Standard_String); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String); Store_Note (N); -------------- @@ -20622,7 +20116,7 @@ package body Sem_Prag is Error_Pragma_Arg ("pragma% takes two arguments", Task_Type); else - Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer); + Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer); end if; Check_First_Subtype (Task_Type); @@ -20700,7 +20194,7 @@ package body Sem_Prag is Check_Arg_Count (1); Check_No_Identifiers; Check_In_Main_Program; - Check_Arg_Is_Static_Expression (Arg1, Standard_Duration); + Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration); if not Error_Posted (Arg1) then Nod := Next (N); @@ -20758,7 +20252,8 @@ package body Sem_Prag is for J in 1 .. 2 loop if Present (Args (J)) then - Check_Arg_Is_Static_Expression (Args (J), Standard_String); + Check_Arg_Is_OK_Static_Expression + (Args (J), Standard_String); end if; end loop; end Title; @@ -21178,6 +20673,30 @@ package body Sem_Prag is Ada_2005_Pragma; Process_Suppress_Unsuppress (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; + + -- Store proper setting of Uneval_Old + + Get_Name_String (Chars (Get_Pragma_Arg (Arg1))); + Uneval_Old := Fold_Upper (Name_Buffer (1)); + ------------------- -- Use_VADS_Size -- ------------------- @@ -21274,6 +20793,8 @@ package body Sem_Prag is -- Warning_As_Error -- ---------------------- + -- pragma Warning_As_Error (static_string_EXPRESSION); + when Pragma_Warning_As_Error => GNAT_Pragma; Check_Arg_Count (1); @@ -25121,6 +24642,15 @@ package body Sem_Prag is Externals.Init; end Initialize; + -------- + -- ip -- + -------- + + procedure ip is + begin + Dummy := Dummy + 1; + end ip; + ----------------------------- -- Is_Config_Static_String -- ----------------------------- @@ -25218,8 +24748,7 @@ package body Sem_Prag is -- 99 special processing required (e.g. for pragma Check) Sig_Flags : constant array (Pragma_Id) of Int := - (Pragma_AST_Entry => -1, - Pragma_Abort_Defer => -1, + (Pragma_Abort_Defer => -1, Pragma_Abstract_State => -1, Pragma_Ada_83 => -1, Pragma_Ada_95 => -1, @@ -25269,6 +24798,7 @@ package body Sem_Prag is Pragma_Debug => -1, Pragma_Debug_Policy => 0, Pragma_Detect_Blocking => -1, + Pragma_Default_Initial_Condition => -1, Pragma_Default_Scalar_Storage_Order => 0, Pragma_Default_Storage_Pool => -1, Pragma_Depends => -1, @@ -25284,7 +24814,6 @@ package body Sem_Prag is Pragma_Eliminate => -1, Pragma_Enable_Atomic_Synchronization => -1, Pragma_Export => -1, - Pragma_Export_Exception => -1, Pragma_Export_Function => -1, Pragma_Export_Object => -1, Pragma_Export_Procedure => -1, @@ -25297,14 +24826,12 @@ package body Sem_Prag is Pragma_External_Name_Casing => -1, Pragma_Fast_Math => -1, Pragma_Finalize_Storage_Only => 0, - Pragma_Float_Representation => 0, Pragma_Global => -1, Pragma_Ident => -1, Pragma_Implementation_Defined => -1, Pragma_Implemented => -1, Pragma_Implicit_Packing => 0, Pragma_Import => +2, - Pragma_Import_Exception => 0, Pragma_Import_Function => 0, Pragma_Import_Object => 0, Pragma_Import_Procedure => 0, @@ -25337,7 +24864,6 @@ package body Sem_Prag is Pragma_List => -1, Pragma_Lock_Free => -1, Pragma_Locking_Policy => -1, - Pragma_Long_Float => -1, Pragma_Loop_Invariant => -1, Pragma_Loop_Optimize => -1, Pragma_Loop_Variant => -1, @@ -25347,6 +24873,7 @@ package body Sem_Prag is Pragma_Memory_Size => -1, Pragma_No_Return => 0, Pragma_No_Body => 0, + Pragma_No_Elaboration_Code_All => -1, Pragma_No_Inline => 0, Pragma_No_Run_Time => -1, Pragma_No_Strict_Aliasing => -1, @@ -25438,6 +24965,7 @@ package body Sem_Prag is Pragma_Unreferenced_Objects => -1, Pragma_Unreserve_All_Interrupts => -1, Pragma_Unsuppress => 0, + Pragma_Unevaluated_Use_Of_Old => 0, Pragma_Use_VADS_Size => -1, Pragma_Validity_Checks => -1, Pragma_Volatile => 0, @@ -25639,6 +25167,9 @@ package body Sem_Prag is return Has_Unconstrained_Component (Typ); end if; + elsif Is_Private_Type (Typ) and then Has_Discriminants (Typ) then + return True; + else return False; end if; @@ -25654,34 +25185,35 @@ 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_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_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_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; @@ -25859,7 +25391,7 @@ package body Sem_Prag is Set_Body_References (State_Id, New_Elmt_List); end if; - Append_Elmt (Ref, Body_References (State_Id)); + Append_Elmt (Ref, To => Body_References (State_Id)); exit; end if; end if; @@ -26054,7 +25586,7 @@ package body Sem_Prag is procedure rv is begin - null; + Dummy := Dummy + 1; end rv; -------------------------------- diff --git a/main/gcc/ada/sem_prag.ads b/main/gcc/ada/sem_prag.ads index 354886dc868..4d6b1c0407e 100644 --- a/main/gcc/ada/sem_prag.ads +++ b/main/gcc/ada/sem_prag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -170,6 +170,18 @@ 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_Subprogram_Inputs_Outputs + (Subp_Id : Entity_Id; + Subp_Inputs : in out Elist_Id; + Subp_Outputs : in out Elist_Id; + Global_Seen : out Boolean); + -- Used during the analysis of pragmas Depends, Global, Refined_Depends, + -- and Refined_Global. Also used by GNATprove. Gathers all inputs and + -- outputs of subprogram Subp_Id in lists Subp_Inputs and Subp_Outputs. + -- If subprogram has no inputs and/or outputs, then the returned list + -- is No_Elist. Global_Seen is set when the related subprogram has + -- pragma [Refined_]Global. + function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean; -- N is a pragma appearing in a configuration pragma file. Most such -- pragmas are analyzed when the file is read, before parsing and analyzing @@ -250,13 +262,11 @@ package Sem_Prag is -- dealing with subprogram body stubs or expression functions. procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id); - -- This routine is used to set an encoded interface name. The node S is an - -- N_String_Literal node for the external name to be set, and E is an + -- This routine is used to set an encoded interface name. The node S is + -- an N_String_Literal node for the external name to be set, and E is an -- entity whose Interface_Name field is to be set. In the normal case where -- S contains a name that is a valid C identifier, then S is simply set as - -- the value of the Interface_Name. Otherwise it is encoded. See the body - -- for details of the encoding. This encoding is only done on VMS systems, - -- since it seems pretty silly, but is needed to pass some dubious tests in - -- the test suite. + -- the value of the Interface_Name. Otherwise it is encoded as needed by + -- particular operating systems. See the body for details of the encoding. end Sem_Prag; diff --git a/main/gcc/ada/sem_res.adb b/main/gcc/ada/sem_res.adb index 97a11d19591..f45e07e06cc 100644 --- a/main/gcc/ada/sem_res.adb +++ b/main/gcc/ada/sem_res.adb @@ -37,6 +37,7 @@ with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; +with Inline; use Inline; with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; @@ -127,6 +128,11 @@ package body Sem_Res is -- for restriction No_Direct_Boolean_Operators. This procedure also handles -- the style check for Style_Check_Boolean_And_Or. + function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean; + -- N is either an indexed component or a selected component. This function + -- returns true if the prefix refers to an object that has an address + -- clause (the case in which we may want to issue a warning). + function Is_Definite_Access_Type (E : Entity_Id) return Boolean; -- Determine whether E is an access type declared by an access declaration, -- and not an (anonymous) allocator type. @@ -224,8 +230,7 @@ package body Sem_Res is -- operators, not ones that are intrinsic imports of back-end builtins. procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); - -- Ditto, for unary operators (arithmetic ones and "not" on signed - -- integer types for VMS). + -- Ditto, for arithmetic unary operators procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, @@ -258,7 +263,7 @@ package body Sem_Res is procedure Simplify_Type_Conversion (N : Node_Id); -- Called after N has been resolved and evaluated, but before range checks -- have been applied. Currently simplifies a combination of floating-point - -- to integer conversion and Truncation attribute. + -- to integer conversion and Rounding or Truncation attribute. function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; -- A universal_fixed expression in an universal context is unambiguous if @@ -1102,7 +1107,10 @@ package body Sem_Res is end if; end if; - Nam := New_Copy (N); + -- The node is the name of the parameterless call. Preserve its + -- descendants, which may be complex expressions. + + Nam := Relocate_Node (N); -- If overloaded, overload set belongs to new copy @@ -1128,6 +1136,29 @@ package body Sem_Res is end if; end Check_Parameterless_Call; + -------------------------------- + -- Is_Atomic_Ref_With_Address -- + -------------------------------- + + function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is + Pref : constant Node_Id := Prefix (N); + + begin + if not Is_Entity_Name (Pref) then + return False; + + else + declare + Pent : constant Entity_Id := Entity (Pref); + Ptyp : constant Entity_Id := Etype (Pent); + begin + return not Is_Access_Type (Ptyp) + and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent)) + and then Present (Address_Clause (Pent)); + end; + end if; + end Is_Atomic_Ref_With_Address; + ----------------------------- -- Is_Definite_Access_Type -- ----------------------------- @@ -1973,7 +2004,7 @@ package body Sem_Res is if Nkind (Decl) = N_Subprogram_Body then Spec := Corresponding_Spec (Decl); - if not No (Spec) then + if Present (Spec) then Decl := Unit_Declaration_Node (Spec); end if; end if; @@ -2975,6 +3006,10 @@ package body Sem_Res is Prev : Node_Id := Empty; Orig_A : Node_Id; + procedure Check_Aliased_Parameter; + -- Check rules on aliased parameters and related accessibility rules + -- in (RM 3.10.2 (10.2-10.4)). + procedure Check_Argument_Order; -- Performs a check for the case where the actuals are all simple -- identifiers that correspond to the formal names, but in the wrong @@ -3011,6 +3046,70 @@ package body Sem_Res is -- This must be determined before the actual is resolved and expanded -- because if needed the transient scope must be introduced earlier. + ------------------------------ + -- Check_Aliased_Parameter -- + ------------------------------ + + procedure Check_Aliased_Parameter is + Nominal_Subt : Entity_Id; + + begin + if Is_Aliased (F) then + if Is_Tagged_Type (A_Typ) then + null; + + elsif Is_Aliased_View (A) then + if Is_Constr_Subt_For_U_Nominal (A_Typ) then + Nominal_Subt := Base_Type (A_Typ); + else + Nominal_Subt := A_Typ; + end if; + + if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then + null; + + -- In a generic body assume the worst for generic formals: + -- they can have a constrained partial view (AI05-041). + + elsif Has_Discriminants (F_Typ) + and then not Is_Constrained (F_Typ) + and then not Has_Constrained_Partial_View (F_Typ) + and then not Is_Generic_Type (F_Typ) + then + null; + + else + Error_Msg_NE ("untagged actual does not match " + & "aliased formal&", A, F); + end if; + + else + Error_Msg_NE ("actual for aliased formal& must be " + & "aliased object", A, F); + end if; + + if Ekind (Nam) = E_Procedure then + null; + + elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then + if Nkind (Parent (N)) = N_Type_Conversion + and then Type_Access_Level (Etype (Parent (N))) < + Object_Access_Level (A) + then + Error_Msg_N ("aliased actual has wrong accessibility", A); + end if; + + elsif Nkind (Parent (N)) = N_Qualified_Expression + and then Nkind (Parent (Parent (N))) = N_Allocator + and then Type_Access_Level (Etype (Parent (Parent (N)))) < + Object_Access_Level (A) + then + Error_Msg_N + ("aliased actual in allocator has wrong accessibility", A); + end if; + end if; + end Check_Aliased_Parameter; + -------------------------- -- Check_Argument_Order -- -------------------------- @@ -3401,7 +3500,7 @@ package body Sem_Res is return Ekind (Ent) = E_Constant and then Present (Constant_Value (Ent)) and then - Is_Static_Expression (Constant_Value (Ent)); + Is_OK_Static_Expression (Constant_Value (Ent)); end; else @@ -3795,6 +3894,16 @@ package body Sem_Res is A_Typ := Etype (A); F_Typ := Etype (F); + -- An actual cannot be an untagged formal incomplete type + + if Ekind (A_Typ) = E_Incomplete_Type + and then not Is_Tagged_Type (A_Typ) + and then Is_Generic_Type (A_Typ) + then + Error_Msg_N + ("invalid use of untagged formal incomplete type", A); + end if; + if Comes_From_Source (Original_Node (N)) and then Nkind_In (Original_Node (N), N_Function_Call, N_Procedure_Call_Statement) @@ -3804,7 +3913,7 @@ package body Sem_Res is -- conversions of objects), not general expressions. if Is_Actual_Tagged_Parameter (A) then - if Is_SPARK_Object_Reference (A) then + if Is_SPARK_05_Object_Reference (A) then null; elsif Nkind (A) = N_Type_Conversion then @@ -3814,8 +3923,8 @@ package body Sem_Res is Target_Typ : constant Entity_Id := A_Typ; begin - if not Is_SPARK_Object_Reference (Operand) then - Check_SPARK_Restriction + if not Is_SPARK_05_Object_Reference (Operand) then + Check_SPARK_05_Restriction ("object required", Operand); -- In formal mode, the only view conversions are those @@ -3831,11 +3940,11 @@ package body Sem_Res is if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("ancestor conversion is the only permitted " & "view conversion", A); else - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("ancestor conversion required", A); end if; @@ -3845,7 +3954,7 @@ package body Sem_Res is end; else - Check_SPARK_Restriction ("object required", A); + Check_SPARK_05_Restriction ("object required", A); end if; -- In formal mode, the only view conversions are those @@ -3854,7 +3963,7 @@ package body Sem_Res is elsif Nkind (A) = N_Type_Conversion and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("ancestor conversion is the only permitted view " & "conversion", A); end if; @@ -3975,35 +4084,29 @@ package body Sem_Res is return; end if; - -- Apply appropriate range checks for in, out, and in-out - -- parameters. Out and in-out parameters also need a separate - -- check, if there is a type conversion, to make sure the return - -- value meets the constraints of the variable before the - -- conversion. - - -- Gigi looks at the check flag and uses the appropriate types. - -- For now since one flag is used there is an optimization which - -- might not be done in the In Out case since Gigi does not do - -- any analysis. More thought required about this ??? + -- Apply appropriate constraint/predicate checks for IN [OUT] case if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then - -- Apply predicate checks, unless this is a call to the - -- predicate check function itself, which would cause an - -- infinite recursion, or it is a call to an initialization - -- procedure whose operand is of course an unfinished object. + -- 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 ??? - if not (Ekind (Nam) = E_Function - and then (Is_Predicate_Function (Nam) - or else - Is_Predicate_Function_M (Nam))) - and then not Is_Init_Proc (Nam) - then + if Predicate_Tests_On_Arguments (Nam) then Apply_Predicate_Check (A, F_Typ); end if; -- Apply required constraint checks + -- Gigi looks at the check flag and uses the appropriate types. + -- For now since one flag is used there is an optimization + -- which might not be done in the IN OUT case since Gigi does + -- not do any analysis. More thought required about this ??? + + -- In fact is this comment obsolete??? doesn't the expander now + -- generate all these tests anyway??? + if Is_Scalar_Type (Etype (A)) then Apply_Scalar_Range_Check (A, F_Typ); @@ -4069,7 +4172,13 @@ package body Sem_Res is end if; end if; + -- Checks for OUT parameters and IN OUT parameters + if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then + + -- If there is a type conversion, to 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 @@ -4079,6 +4188,9 @@ package body Sem_Res is (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). + else if Is_Scalar_Type (F_Typ) then Apply_Scalar_Range_Check (A, A_Typ, F_Typ); @@ -4090,6 +4202,10 @@ package body Sem_Res is Apply_Range_Check (A, A_Typ, F_Typ); end if; end if; + + -- Note: we do not apply the predicate checks for the case of + -- OUT and IN OUT parameters. They are instead applied in the + -- Expand_Actuals routine in Exp_Ch6. end if; -- An actual associated with an access parameter is implicitly @@ -4212,6 +4328,8 @@ package body Sem_Res is end if; end if; + Check_Aliased_Parameter; + Eval_Actual (A); -- If it is a named association, treat the selector_name as a @@ -4238,21 +4356,24 @@ package body Sem_Res is end if; -- The following checks are only relevant when SPARK_Mode is on as - -- they are not standard Ada legality rule. + -- they are not standard Ada legality rule. Internally generated + -- temporaries are ignored. if SPARK_Mode = On - and then Is_SPARK_Volatile_Object (A) + and then Is_Effectively_Volatile_Object (A) + and then Comes_From_Source (A) then - -- A volatile object may act as an actual parameter when the - -- corresponding formal is of a non-scalar volatile type. + -- An effectively volatile object may act as an actual + -- parameter when the corresponding formal is of a non-scalar + -- volatile type. if Is_Volatile (Etype (F)) and then not Is_Scalar_Type (Etype (F)) then null; - -- A volatile object may act as an actual parameter in a call - -- to an instance of Unchecked_Conversion. + -- An effectively volatile object may act as an actual + -- parameter in a call to an instance of Unchecked_Conversion. elsif Is_Unchecked_Conversion_Instance (Nam) then null; @@ -4265,9 +4386,9 @@ package body Sem_Res is -- Detect an external variable with an enabled property that -- does not match the mode of the corresponding formal in a - -- procedure call. - - -- why only procedure calls ??? + -- procedure call. Functions are not considered because they + -- cannot have effectively volatile formal parameters in the + -- first place. if Ekind (Nam) = E_Procedure and then Is_Entity_Name (A) @@ -4425,6 +4546,7 @@ package body Sem_Res is end if; Resolve (Expression (E), Etype (E)); + Check_Non_Static_Context (Expression (E)); Check_Unset_Reference (Expression (E)); -- A qualified expression requires an exact match of the type. @@ -5135,7 +5257,7 @@ package body Sem_Res is Eval_Arithmetic_Op (N); -- In SPARK, a multiplication or division with operands of fixed point - -- types shall be qualified or explicitly converted to identify the + -- types must be qualified or explicitly converted to identify the -- result type. if (Is_Fixed_Point_Type (Etype (L)) @@ -5144,7 +5266,7 @@ package body Sem_Res is and then not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("operation should be qualified or explicitly converted", N); end if; @@ -5277,15 +5399,6 @@ package body Sem_Res is ------------------ procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Subp : constant Node_Id := Name (N); - Nam : Entity_Id; - I : Interp_Index; - It : Interp; - Norm_OK : Boolean; - Scop : Entity_Id; - Rtype : Entity_Id; - function Same_Or_Aliased_Subprograms (S : Entity_Id; E : Entity_Id) return Boolean; @@ -5305,6 +5418,20 @@ package body Sem_Res is return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); end Same_Or_Aliased_Subprograms; + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Subp : constant Node_Id := Name (N); + Body_Id : Entity_Id; + I : Interp_Index; + It : Interp; + Nam : Entity_Id; + Nam_Decl : Node_Id; + Nam_UA : Entity_Id; + Norm_OK : Boolean; + Rtype : Entity_Id; + Scop : Entity_Id; + -- Start of processing for Resolve_Call begin @@ -5511,7 +5638,7 @@ package body Sem_Res is and then Ekind (Nam) /= E_Enumeration_Literal then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("call to subprogram cannot appear before its body", N); end if; @@ -5681,7 +5808,7 @@ package body Sem_Res is if Restriction_Check_Required (SPARK_05) and then Same_Or_Aliased_Subprograms (Nam, Scop) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("subprogram may not contain direct call to itself", N); end if; @@ -5845,18 +5972,9 @@ package body Sem_Res is -- check for this by traversing the type in Check_Initialization_Call. if Is_Inlined (Nam) - and then Has_Pragma_Inline_Always (Nam) - and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration - and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) - and then not Debug_Flag_Dot_K - then - null; - - elsif Is_Inlined (Nam) and then Has_Pragma_Inline (Nam) and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) - and then Debug_Flag_Dot_K then null; @@ -6059,7 +6177,7 @@ package body Sem_Res is and then Is_Entity_Name (Name (N)) and then Is_Inherited_Operation_For_Type (Entity (Name (N)), Etype (N)) then - Check_SPARK_Restriction ("function not inherited", N); + Check_SPARK_05_Restriction ("function not inherited", N); end if; -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is @@ -6122,6 +6240,85 @@ package body Sem_Res is Eval_Call (N); Check_Elab_Call (N); + + -- In GNATprove mode, expansion is disabled, but we want to inline some + -- subprograms to facilitate formal verification. Indirect calls through + -- a subprogram type or within a generic cannot be inlined. Inlining is + -- performed only for calls subject to SPARK_Mode on. + + if GNATprove_Mode + and then SPARK_Mode = On + and then Is_Overloadable (Nam) + and then not Inside_A_Generic + then + Nam_UA := Ultimate_Alias (Nam); + Nam_Decl := Unit_Declaration_Node (Nam_UA); + + if Nkind (Nam_Decl) = N_Subprogram_Declaration then + Body_Id := Corresponding_Body (Nam_Decl); + + -- Nothing to do if the subprogram is not eligible for inlining in + -- GNATprove mode. + + if not Is_Inlined_Always (Nam_UA) + or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id) + then + null; + + -- Calls cannot be inlined inside assertions, as GNATprove treats + -- assertions as logic expressions. + + elsif In_Assertion_Expr /= 0 then + Error_Msg_NE ("?no contextual analysis of &", N, Nam); + Error_Msg_N ("\call appears in assertion expression", N); + Set_Is_Inlined_Always (Nam_UA, False); + + -- Calls cannot be inlined inside default expressions + + elsif In_Default_Expr then + Error_Msg_NE ("?no contextual analysis of &", N, Nam); + Error_Msg_N ("\call appears in default expression", N); + Set_Is_Inlined_Always (Nam_UA, False); + + -- Inlining should not be performed during pre-analysis + + elsif Full_Analysis then + + -- With the one-pass inlining technique, a call cannot be + -- inlined if the corresponding body has not been seen yet. + + if No (Body_Id) then + Error_Msg_NE + ("?no contextual analysis of & (body not seen yet)", + N, Nam); + Set_Is_Inlined_Always (Nam_UA, False); + + -- Nothing to do if there is no body to inline, indicating that + -- the subprogram is not suitable for inlining in GNATprove + -- mode. + + elsif No (Body_To_Inline (Nam_Decl)) then + null; + + -- 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 ("?no contextual analysis of &", N, Nam); + Error_Msg_N + ("\call appears in potentially unevaluated context", N); + Set_Is_Inlined_Always (Nam_UA, False); + + -- Otherwise, inline the call + + else + Expand_Inlined_Call (N, Nam_UA, Nam); + end if; + end if; + end if; + end if; + Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; @@ -6293,13 +6490,13 @@ package body Sem_Res is -- types or array types except String. if Is_Boolean_Type (T) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("comparison is not defined on Boolean type", N); elsif Is_Array_Type (T) and then Base_Type (T) /= Standard_String then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("comparison is not defined on array types other than String", N); end if; @@ -6420,6 +6617,13 @@ package body Sem_Res is function Appears_In_Check (Nod : Node_Id) return Boolean; -- Denote whether an arbitrary node Nod appears in a check node + 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(13)) where volatile reference Obj_Ref + -- can safely reside. + ---------------------- -- Appears_In_Check -- ---------------------- @@ -6447,6 +6651,64 @@ package body Sem_Res is return False; end Appears_In_Check; + ---------------------------- + -- Is_OK_Volatile_Context -- + ---------------------------- + + function Is_OK_Volatile_Context + (Context : Node_Id; + Obj_Ref : Node_Id) return Boolean + is + 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. Ensure that the climb of the parent chain came + -- from the expression side and not from the name side. + + elsif Nkind (Context) = N_Object_Declaration + and then Present (Expression (Context)) + and then Expression (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_Unchecked_Conversion_Instance (Entity (Name (Context))) + and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration + then + return True; + + -- The volatile object appears as the prefix of a name occurring + -- in a non-interfering context. + + elsif Nkind_In (Context, N_Attribute_Reference, + 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; + + -- Allow references to volatile objects in various checks. This is + -- not a direct SPARK 2014 requirement. + + elsif Appears_In_Check (Context) then + return True; + + else + return False; + end if; + end Is_OK_Volatile_Context; + -- Local variables E : constant Entity_Id := Entity (N); @@ -6556,53 +6818,33 @@ package body Sem_Res is Eval_Entity_Name (N); end if; - -- A volatile object subject to enabled properties Async_Writers or - -- Effective_Reads must appear in a specific context. The following - -- checks are only relevant when SPARK_Mode is on as they are not - -- standard Ada legality rules. + -- An effectively volatile object subject to enabled properties + -- Async_Writers or Effective_Reads must appear in a specific context. + -- The following checks are only relevant when SPARK_Mode is on as they + -- are not standard Ada legality rules. if SPARK_Mode = On and then Is_Object (E) - and then Is_SPARK_Volatile (E) + and then Is_Effectively_Volatile (E) and then Comes_From_Source (E) and then (Async_Writers_Enabled (E) or else Effective_Reads_Enabled (E)) then - -- The volatile object can appear on either side of an assignment - - if Nkind (Par) = N_Assignment_Statement then - null; + -- The effectively volatile objects appears in a "non-interfering + -- context" as defined in SPARK RM 7.1.3(13). - -- The volatile object is part of the initialization expression of - -- another object. Ensure that the climb of the parent chain came - -- from the expression side and not from the name side. - - elsif Nkind (Par) = N_Object_Declaration - and then Present (Expression (Par)) - and then N = Expression (Par) - then + if Is_OK_Volatile_Context (Par, N) then null; - -- The volatile object appears as an actual parameter in a call to an - -- instance of Unchecked_Conversion whose result is renamed. - - elsif Nkind (Par) = N_Function_Call - and then Is_Unchecked_Conversion_Instance (Entity (Name (Par))) - and then Nkind (Parent (Par)) = N_Object_Renaming_Declaration - then - null; - - -- Assume that references to volatile objects that appear as actual - -- parameters in a procedure call are always legal. The full legality - -- check is done when the actuals are resolved. + -- Assume that references to effectively volatile objects that appear + -- as actual parameters in a procedure call are always legal. The + -- full legality check is done when the actuals are resolved. elsif Nkind (Par) = N_Procedure_Call_Statement then null; - -- Allow references to volatile objects in various checks - - elsif Appears_In_Check (Par) then - null; + -- Otherwise the context causes a side effect with respect to the + -- effectively volatile object. else Error_Msg_N @@ -6969,7 +7211,11 @@ package body Sem_Res is New_Occurrence_Of (PPC_Wrapper (Nam), Loc), Parameter_Associations => New_Actuals); Rewrite (N, New_Call); - Analyze_And_Resolve (N); + + -- Preanalyze and resolve new call. Current procedure is called + -- from Resolve_Call, after which expansion will take place. + + Preanalyze_And_Resolve (N); return; end; end if; @@ -7296,7 +7542,7 @@ package body Sem_Res is and then Etype (R) /= Any_Composite -- or else R in error and then not Matching_Static_Array_Bounds (Etype (L), Etype (R)) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("array types should have matching static bounds", N); end if; end if; @@ -7755,19 +8001,20 @@ package body Sem_Res is Eval_Indexed_Component (N); end if; - -- If the array type is atomic, and is packed, and we are in a left side - -- context, then this is worth a warning, since we have a situation - -- where the access to the component may cause extra read/writes of - -- the atomic array object, which could be considered unexpected. + -- If the array type is atomic, and the component is not atomic, then + -- this is worth a warning, since we have a situation where the access + -- to the component may cause extra read/writes of the atomic array + -- object, or partial word accesses, which could be unexpected. if Nkind (N) = N_Indexed_Component - and then (Is_Atomic (Array_Type) - or else (Is_Entity_Name (Prefix (N)) - and then Is_Atomic (Entity (Prefix (N))))) - and then Is_Bit_Packed_Array (Array_Type) - and then Is_LHS (N) = Yes + and then Is_Atomic_Ref_With_Address (N) + and then not (Has_Atomic_Components (Array_Type) + or else (Is_Entity_Name (Prefix (N)) + and then Has_Atomic_Components + (Entity (Prefix (N))))) + and then not Is_Atomic (Component_Type (Array_Type)) then - Error_Msg_N ("??assignment to component of packed atomic array", + Error_Msg_N ("??access to non-atomic component of atomic array", Prefix (N)); Error_Msg_N ("??\may cause unexpected accesses to atomic object", Prefix (N)); @@ -7789,11 +8036,10 @@ package body Sem_Res is -------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); - Op : Entity_Id; - Orig_Op : constant Entity_Id := Entity (N); - Arg1 : Node_Id; - Arg2 : Node_Id; + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; function Convert_Operand (Opnd : Node_Id) return Node_Id; -- If the operand is a literal, it cannot be the expression in a @@ -7873,31 +8119,19 @@ package body Sem_Res is or else Typ /= Etype (Right_Opnd (N)) then -- Add explicit conversion where needed, and save interpretations in - -- case operands are overloaded. If the context is a VMS operation, - -- assert that the conversion is legal (the operands have the proper - -- types to select the VMS intrinsic). Note that in rare cases the - -- VMS operators may be visible, but the default System is being used - -- and Address is a private type. + -- case operands are overloaded. Arg1 := Convert_To (Typ, Left_Opnd (N)); Arg2 := Convert_To (Typ, Right_Opnd (N)); if Nkind (Arg1) = N_Type_Conversion then Save_Interps (Left_Opnd (N), Expression (Arg1)); - - if Is_VMS_Operator (Orig_Op) then - Set_Conversion_OK (Arg1); - end if; else Save_Interps (Left_Opnd (N), Arg1); end if; if Nkind (Arg2) = N_Type_Conversion then Save_Interps (Right_Opnd (N), Expression (Arg2)); - - if Is_VMS_Operator (Orig_Op) then - Set_Conversion_OK (Arg2); - end if; else Save_Interps (Right_Opnd (N), Arg2); end if; @@ -7969,18 +8203,13 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; - -- OK if this is a VMS-specific intrinsic operation - - if Is_VMS_Operator (Entity (N)) then - null; - -- The following test is required because the operands of the operation -- may be literals, in which case the resulting type appears to be -- compatible with a signed integer type, when in fact it is compatible -- only with modular types. If the context itself is universal, the -- operation is illegal. - elsif not Valid_Boolean_Arg (Typ) then + if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid context for logical operation", N); Set_Etype (N, Any_Type); return; @@ -8072,7 +8301,7 @@ package body Sem_Res is and then Right_Typ /= Any_Composite -- or Right_Opnd in error and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("array types should have matching static bounds", N); end if; end; @@ -8145,7 +8374,7 @@ package body Sem_Res is Nalts := 0; Alt := First (Alternatives (N)); while Present (Alt) loop - if Is_Static_Expression (Alt) + if Is_OK_Static_Expression (Alt) and then (Nkind_In (Alt, N_Integer_Literal, N_Character_Literal) or else Nkind (Alt) in N_Has_Entity) @@ -8176,8 +8405,7 @@ package body Sem_Res is if Present (Alternatives (N)) then Resolve_Set_Membership; - Check_Function_Writable_Actuals (N); - return; + goto SM_Exit; elsif not Is_Overloaded (R) and then @@ -8240,6 +8468,10 @@ package body Sem_Res is Check_Unset_Reference (R); end if; + -- Here after resolving membership operation + + <> + Eval_Membership_Op (N); Check_Function_Writable_Actuals (N); end Resolve_Membership_Op; @@ -8368,7 +8600,7 @@ package body Sem_Res is end loop; if Base_Type (Etype (N)) /= Standard_String then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("result of concatenation should have type String", N); end if; end Resolve_Op_Concat; @@ -8502,17 +8734,17 @@ package body Sem_Res is -- separately on each final operand, past concatenation operations. if Is_Character_Type (Etype (Arg)) then - if not Is_Static_Expression (Arg) then - Check_SPARK_Restriction + if not Is_OK_Static_Expression (Arg) then + Check_SPARK_05_Restriction ("character operand for concatenation should be static", Arg); end if; elsif Is_String_Type (Etype (Arg)) then if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name) and then Is_Constant_Object (Entity (Arg))) - and then not Is_Static_Expression (Arg) + and then not Is_OK_Static_Expression (Arg) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("string operand for concatenation should be static", Arg); end if; @@ -8730,12 +8962,9 @@ package body Sem_Res is B_Typ := Base_Type (Typ); end if; - if Is_VMS_Operator (Entity (N)) then - null; - -- Straightforward case of incorrect arguments - elsif not Valid_Boolean_Arg (Typ) then + if not Valid_Boolean_Arg (Typ) then Error_Msg_N ("invalid operand type for operator&", N); Set_Etype (N, Any_Type); return; @@ -8826,7 +9055,7 @@ package body Sem_Res is and then Etype (Expr) /= Any_Composite -- or else Expr in error and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr)) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("array types should have matching static bounds", N); end if; @@ -8858,6 +9087,16 @@ package body Sem_Res is Analyze_Dimension (N); Eval_Qualified_Expression (N); + + -- If we still have a qualified expression after the static evaluation, + -- then apply a scalar range check if needed. The reason that we do this + -- after the Eval call is that otherwise, the application of the range + -- check may convert an illegal static expression and result in warning + -- rather than giving an error (e.g Integer'(Integer'Last + 1)). + + if Nkind (N) = N_Qualified_Expression and then Is_Scalar_Type (Typ) then + Apply_Scalar_Range_Check (Expr, Typ); + end if; end Resolve_Qualified_Expression; ------------------------------ @@ -8966,11 +9205,11 @@ package body Sem_Res is if Is_Discrete_Type (Typ) and then Expander_Active then if Is_OK_Static_Expression (L) then - Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); + Fold_Uint (L, Expr_Value (L), Is_OK_Static_Expression (L)); end if; if Is_OK_Static_Expression (H) then - Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); + Fold_Uint (H, Expr_Value (H), Is_OK_Static_Expression (H)); end if; end if; end Resolve_Range; @@ -9016,7 +9255,7 @@ package body Sem_Res is -- Generate a warning if literal from source - if Is_Static_Expression (N) + if Is_OK_Static_Expression (N) and then Warn_On_Bad_Fixed_Value then Error_Msg_N @@ -9029,7 +9268,7 @@ package body Sem_Res is -- by truncation, since Machine_Rounds is false for all GNAT -- fixed-point types (RM 4.9(38)). - Stat := Is_Static_Expression (N); + Stat := Is_OK_Static_Expression (N); Rewrite (N, Make_Real_Literal (Sloc (N), Realval => Small_Value (Typ) * Cint)); @@ -9083,7 +9322,7 @@ package body Sem_Res is procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is Comp : Entity_Id; Comp1 : Entity_Id := Empty; -- prevent junk warning - P : constant Node_Id := Prefix (N); + P : constant Node_Id := Prefix (N); S : constant Node_Id := Selector_Name (N); T : Entity_Id := Etype (P); I : Interp_Index; @@ -9260,22 +9499,22 @@ package body Sem_Res is -- Note: No Eval processing is required, because the prefix is of a -- record type, or protected type, and neither can possibly be static. - -- If the array type is atomic, and is packed, and we are in a left side - -- context, then this is worth a warning, since we have a situation - -- where the access to the component may cause extra read/writes of the - -- atomic array object, which could be considered unexpected. + -- If the record type is atomic, and the component is non-atomic, then + -- this is worth a warning, since we have a situation where the access + -- to the component may cause extra read/writes of the atomic array + -- object, or partial word accesses, both of which may be unexpected. if Nkind (N) = N_Selected_Component - and then (Is_Atomic (T) - or else (Is_Entity_Name (Prefix (N)) - and then Is_Atomic (Entity (Prefix (N))))) - and then Is_Packed (T) - and then Is_LHS (N) = Yes + and then Is_Atomic_Ref_With_Address (N) + and then not Is_Atomic (Entity (S)) + and then not Is_Atomic (Etype (Entity (S))) then Error_Msg_N - ("??assignment to component of packed atomic record", Prefix (N)); + ("??access to non-atomic component of atomic record", + Prefix (N)); Error_Msg_N - ("\??may cause unexpected accesses to atomic object", Prefix (N)); + ("\??may cause unexpected accesses to atomic object", + Prefix (N)); end if; Analyze_Dimension (N); @@ -9629,14 +9868,27 @@ package body Sem_Res is -- Check bad use of type with predicates - if Has_Predicates (Etype (Drange)) then - Bad_Predicated_Subtype_Use - ("subtype& has predicate, not allowed in slice", - Drange, Etype (Drange)); + declare + Subt : Entity_Id; + + begin + if Nkind (Drange) = N_Subtype_Indication + and then Has_Predicates (Entity (Subtype_Mark (Drange))) + then + Subt := Entity (Subtype_Mark (Drange)); + else + Subt := Etype (Drange); + end if; + + if Has_Predicates (Subt) then + Bad_Predicated_Subtype_Use + ("subtype& has predicate, not allowed in slice", Drange, Subt); + end if; + end; -- Otherwise here is where we check suspicious indexes - elsif Nkind (Drange) = N_Range then + if Nkind (Drange) = N_Range then Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); Warn_On_Suspicious_Index (Name, High_Bound (Drange)); end if; @@ -10022,7 +10274,7 @@ package body Sem_Res is and then Operand_Typ /= Any_Composite -- or else Operand in error and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ) then - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("array types should have matching static bounds", N); end if; @@ -10034,9 +10286,9 @@ package body Sem_Res is and then Is_Tagged_Type (Operand_Typ) and then not Is_Class_Wide_Type (Operand_Typ) and then Is_Ancestor (Target_Typ, Operand_Typ) - and then not Is_SPARK_Object_Reference (Operand) + and then not Is_SPARK_05_Object_Reference (Operand) then - Check_SPARK_Restriction ("object required", Operand); + Check_SPARK_05_Restriction ("object required", Operand); end if; Analyze_Dimension (N); @@ -10109,11 +10361,11 @@ package body Sem_Res is -- odd subtype coming from the bounds). if (Is_Entity_Name (Orig_N) - and then - (Etype (Entity (Orig_N)) = Orig_T - or else - (Ekind (Entity (Orig_N)) = E_Loop_Parameter - and then Covers (Orig_T, Etype (Entity (Orig_N)))))) + and then + (Etype (Entity (Orig_N)) = Orig_T + or else + (Ekind (Entity (Orig_N)) = E_Loop_Parameter + and then Covers (Orig_T, Etype (Entity (Orig_N)))))) -- If not an entity, then type of expression must match @@ -10193,6 +10445,17 @@ package body Sem_Res is Target : Entity_Id := Target_Typ; begin + -- If the type of the operand is a limited view, use the non- + -- limited view when available. + + if From_Limited_With (Opnd) + and then Ekind (Opnd) in Incomplete_Kind + and then Present (Non_Limited_View (Opnd)) + then + Opnd := Non_Limited_View (Opnd); + Set_Etype (Expression (N), Opnd); + end if; + if Is_Access_Type (Opnd) then Opnd := Designated_Type (Opnd); end if; @@ -10280,6 +10543,19 @@ package body Sem_Res is Apply_Predicate_Check (N, Target_Typ); end if; end if; + + -- If at this stage we have a real to integer conversion, make sure + -- that the Do_Range_Check flag is set, because such conversions in + -- general need a range check. We only need this if expansion is off + -- or we are in GNATProve mode. + + if Nkind (N) = N_Type_Conversion + and then (GNATprove_Mode or not Expander_Active) + and then Is_Integer_Type (Target_Typ) + and then Is_Real_Type (Operand_Typ) + then + Set_Do_Range_Check (Operand); + end if; end Resolve_Type_Conversion; ---------------------- @@ -10296,7 +10572,7 @@ package body Sem_Res is begin if Is_Modular_Integer_Type (Typ) and then Nkind (N) /= N_Op_Not then Error_Msg_Name_1 := Chars (Typ); - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("unary operator not defined for modular type%", N); end if; @@ -10509,6 +10785,19 @@ package body Sem_Res is -- Resolve operand using its own type Resolve (Operand, Opnd_Type); + + -- In an inlined context, the unchecked conversion may be applied + -- to a literal, in which case its type is the type of the context. + -- (In other contexts conversions cannot apply to literals). + + if In_Inlined_Body + and then (Opnd_Type = Any_Character or else + Opnd_Type = Any_Integer or else + Opnd_Type = Any_Real) + then + Set_Etype (Operand, Typ); + end if; + Analyze_Dimension (N); Eval_Unchecked_Conversion (N); end Resolve_Unchecked_Type_Conversion; @@ -10854,29 +11143,36 @@ package body Sem_Res is Opnd_Typ : constant Entity_Id := Etype (Operand); begin - if Is_Floating_Point_Type (Opnd_Typ) - and then - (Is_Integer_Type (Target_Typ) - or else (Is_Fixed_Point_Type (Target_Typ) - and then Conversion_OK (N))) - and then Nkind (Operand) = N_Attribute_Reference - and then Attribute_Name (Operand) = Name_Truncation - - -- Special processing required if the conversion is the expression - -- of a Truncation attribute reference. In this case we replace: + -- Special processing if the conversion is the expression of a + -- Rounding or Truncation attribute reference. In this case we + -- replace: - -- ityp (ftyp'Truncation (x)) + -- ityp (ftyp'Rounding (x)) or ityp (ftyp'Truncation (x)) -- by -- ityp (x) - -- with the Float_Truncate flag set, which is more efficient. + -- with the Float_Truncate flag set to False or True respectively, + -- which is more efficient. + if Is_Floating_Point_Type (Opnd_Typ) + and then + (Is_Integer_Type (Target_Typ) + or else (Is_Fixed_Point_Type (Target_Typ) + and then Conversion_OK (N))) + and then Nkind (Operand) = N_Attribute_Reference + and then Nam_In (Attribute_Name (Operand), Name_Rounding, + Name_Truncation) then - Rewrite (Operand, - Relocate_Node (First (Expressions (Operand)))); - Set_Float_Truncate (N, True); + declare + Truncate : constant Boolean := + Attribute_Name (Operand) = Name_Truncation; + begin + Rewrite (Operand, + Relocate_Node (First (Expressions (Operand)))); + Set_Float_Truncate (N, Truncate); + end; end if; end; end if; @@ -11280,13 +11576,6 @@ package body Sem_Res is -- this context, but which cannot be removed by type checking, -- because the context does not impose a type. - -- When compiling for VMS, spurious ambiguities can be produced - -- when arithmetic operations have a literal operand and return - -- System.Address or a descendant of it. These ambiguities are - -- otherwise resolved by the context, but for conversions there - -- is no context type and the removal of the spurious operations - -- must be done explicitly here. - -- The node may be labelled overloaded, but still contain only one -- interpretation because others were discarded earlier. If this -- is the case, retain the single interpretation if legal. @@ -11306,7 +11595,15 @@ package body Sem_Res is Remove_Interp (I); end if; - if Present (System_Aux_Id) + -- When compiling for a system where Address is of a visible + -- integer type, spurious ambiguities can be produced when + -- arithmetic operations have a literal operand and return + -- System.Address or a descendant of it. These ambiguities + -- are usually resolved by the context, but for conversions + -- there is no context type and the removal of the spurious + -- operations must be done explicitly here. + + if not Address_Is_Private and then Is_Descendent_Of_Address (It.Typ) then Remove_Interp (I); diff --git a/main/gcc/ada/sem_util.adb b/main/gcc/ada/sem_util.adb index 1716095b5f9..01c16244621 100644 --- a/main/gcc/ada/sem_util.adb +++ b/main/gcc/ada/sem_util.adb @@ -48,6 +48,7 @@ with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; 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; @@ -72,15 +73,15 @@ 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. + -- 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. + -- 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 @@ -89,10 +90,10 @@ package body Sem_Util is -- 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. + -- 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) @@ -153,8 +154,8 @@ package body Sem_Util is elsif Nkind (Parent (Typ)) = N_Private_Type_Declaration then if Present (Full_View (Typ)) - and then Nkind (Parent (Full_View (Typ))) - = N_Full_Type_Declaration + and then + Nkind (Parent (Full_View (Typ))) = N_Full_Type_Declaration then Nod := Type_Definition (Parent (Full_View (Typ))); @@ -781,15 +782,63 @@ package body Sem_Util is Typ : Entity_Id; Suggest_Static : Boolean := False) is + Gen : Entity_Id; + begin - if Has_Predicates (Typ) then + -- Avoid cascaded errors + + if Error_Posted (N) then + return; + end if; + + if Inside_A_Generic then + Gen := Current_Scope; + while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop + Gen := Scope (Gen); + end loop; + + if No (Gen) then + return; + end if; + + if Is_Generic_Formal (Typ) + and then Is_Discrete_Type (Typ) + then + Set_No_Predicate_On_Actual (Typ); + end if; + + elsif Has_Predicates (Typ) then if Is_Generic_Actual_Type (Typ) then - Error_Msg_Warn := SPARK_Mode /= On; - Error_Msg_FE (Msg & "<<", N, Typ); - Error_Msg_F ("\Program_Error [<<", N); - Insert_Action (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Bad_Predicated_Generic_Type)); + + -- The restriction on loop parameters is only that the type + -- should have no dynamic predicates. + + if Nkind (Parent (N)) = N_Loop_Parameter_Specification + and then not Has_Dynamic_Predicate_Aspect (Typ) + and then Is_OK_Static_Subtype (Typ) + then + return; + end if; + + Gen := Current_Scope; + while not Is_Generic_Instance (Gen) loop + Gen := Scope (Gen); + end loop; + + pragma Assert (Present (Gen)); + + if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then + Error_Msg_Warn := SPARK_Mode /= On; + Error_Msg_FE (Msg & "<<", N, Typ); + Error_Msg_F ("\Program_Error [<<", N); + + Insert_Action (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Bad_Predicated_Generic_Type)); + + else + Error_Msg_FE (Msg & "<<", N, Typ); + end if; else Error_Msg_FE (Msg, N, Typ); @@ -798,7 +847,7 @@ package body Sem_Util is -- Emit an optional suggestion on how to remedy the error if the -- context warrants it. - if Suggest_Static and then Present (Static_Predicate (Typ)) then + if Suggest_Static and then Has_Static_Predicate (Typ) then Error_Msg_FE ("\predicate of & should be marked static", N, Typ); end if; end if; @@ -1181,6 +1230,242 @@ 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_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; + + -- 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; + + 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, ); + + 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 Default_Init_Cond (I : ) is + -- begin + -- ; + -- end 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); + 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); + 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)); + + 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); + + -- Generate: + -- procedure Default_Init_Cond (Inn : ); + + 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)))))); + end Build_Default_Init_Cond_Procedure_Declaration; + --------------------------- -- Build_Default_Subtype -- --------------------------- @@ -1684,55 +1969,6 @@ package body Sem_Util is end if; end Check_Dynamically_Tagged_Expression; - ----------------------------------------------- - -- Check_Expression_Against_Static_Predicate -- - ----------------------------------------------- - - procedure Check_Expression_Against_Static_Predicate - (Expr : Node_Id; - Typ : Entity_Id) - is - begin - -- When the predicate is static and the value of the expression is known - -- at compile time, evaluate the predicate check. A type is non-static - -- when it has aspect Dynamic_Predicate, but if the dynamic predicate - -- was predicate-static, we still check it statically. After all this - -- is only a warning, not an error. - - if Compile_Time_Known_Value (Expr) - and then Has_Predicates (Typ) - and then Has_Static_Predicate (Typ) - then - -- Either -gnatc is enabled or the expression is ok - - if Operating_Mode < Generate_Code - or else Eval_Static_Predicate_Check (Expr, Typ) - then - null; - - -- The expression is prohibited by the static predicate. There has - -- been some debate if this is an illegality (in the case where - -- the static predicate was explicitly given as such), but that - -- discussion decided this was not illegal, just a warning situation. - - else - Error_Msg_NE - ("??static expression fails predicate check on &", Expr, Typ); - - -- We now reset the static expression indication on the expression - -- since it is no longer static if it fails a predicate test. We - -- do not do this if the predicate was officially dynamic, since - -- dynamic predicates don't affect legality in this manner. - - if not Has_Dynamic_Predicate_Aspect (Typ) then - Error_Msg_N - ("\??expression is no longer considered static", Expr); - Set_Is_Static_Expression (Expr, False); - end if; - end if; - end if; - end Check_Expression_Against_Static_Predicate; - -------------------------- -- Check_Fully_Declared -- -------------------------- @@ -1883,11 +2119,7 @@ package body Sem_Util is return Abandon; end if; - if Writable_Actuals_List = No_Elist then - Writable_Actuals_List := New_Elmt_List; - end if; - - Append_Elmt (N, Writable_Actuals_List); + Append_New_Elmt (N, To => Writable_Actuals_List); else if Identifiers_List = No_Elist then @@ -1944,7 +2176,7 @@ package body Sem_Util is return; end if; - if Nkind (N) in N_Subexpr and then Is_Static_Expression (N) then + if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then return; end if; @@ -2198,7 +2430,7 @@ package body Sem_Util is Get_Index_Bounds (Choice, L, H); pragma Assert (Compile_Time_Known_Value (L) - and then Compile_Time_Known_Value (H)); + and then Compile_Time_Known_Value (H)); Count_Components := Count_Components + Expr_Value (H) - Expr_Value (L) + 1; @@ -2209,7 +2441,7 @@ package body Sem_Util is -- bounds. else - pragma Assert (Is_Static_Expression (Choice) + pragma Assert (Is_OK_Static_Expression (Choice) or else Nkind (Choice) = N_Identifier or else Nkind (Choice) = N_Integer_Literal); @@ -2280,7 +2512,7 @@ package body Sem_Util is if Present (Expressions (N)) then Comp_Expr := First (Expressions (N)); while Present (Comp_Expr) loop - if not Is_Static_Expression (Comp_Expr) then + if not Is_OK_Static_Expression (Comp_Expr) then Collect_Identifiers (Comp_Expr); end if; @@ -2413,9 +2645,7 @@ package body Sem_Util is elsif not Comes_From_Source (Nam) then return; - elsif Is_Entity_Name (Nam) - and then Is_Type (Entity (Nam)) - then + elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then null; else @@ -2564,7 +2794,7 @@ package body Sem_Util is end if; else Error_Msg_Sloc := Body_Sloc; - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("decl cannot appear after body#", Decl); end if; end if; @@ -2591,11 +2821,7 @@ package body Sem_Util is -- Check for Is_Imported needs commenting below ??? if VM_Target /= No_VM - and then (Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_Constant - or else - Ekind (Ent) = E_Loop_Parameter) + and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) and then Scope (Ent) /= Empty and then not Is_Library_Level_Entity (Ent) and then not Is_Imported (Ent) @@ -2611,9 +2837,7 @@ package body Sem_Util is Enclosing := Enclosing_Subprogram (Ent); - if Enclosing /= Empty - and then Enclosing /= Current_Subp - then + if Enclosing /= Empty and then Enclosing /= Current_Subp then Set_Has_Up_Level_Access (Ent, True); end if; end if; @@ -2818,7 +3042,7 @@ package body Sem_Util is Comes_From_Source (N) and then Is_Entity_Name (N) and then (Entity (N) = Standard_True - or else Entity (N) = Standard_False); + or else Entity (N) = Standard_False); end Is_Trivial_Boolean; ------------------------- @@ -2908,31 +3132,6 @@ package body Sem_Util is end if; end Check_Result_And_Post_State; - --------------------------------- - -- Check_SPARK_Mode_In_Generic -- - --------------------------------- - - procedure Check_SPARK_Mode_In_Generic (N : Node_Id) is - Aspect : Node_Id; - - begin - -- Try to find aspect SPARK_Mode and flag it as illegal - - if Has_Aspects (N) then - Aspect := First (Aspect_Specifications (N)); - while Present (Aspect) loop - if Get_Aspect_Id (Aspect) = Aspect_SPARK_Mode then - Error_Msg_Name_1 := Name_SPARK_Mode; - Error_Msg_N - ("incorrect placement of aspect % on a generic", Aspect); - exit; - end if; - - Next (Aspect); - end loop; - end if; - end Check_SPARK_Mode_In_Generic; - ------------------------------ -- Check_Unprotected_Access -- ------------------------------ @@ -2999,9 +3198,7 @@ package body Sem_Util is begin S := Current_Scope; - while Present (S) - and then S /= Pref_Encl_Typ - loop + while Present (S) and then S /= Pref_Encl_Typ loop if Scope (S) = Pref_Encl_Typ then E := First_Entity (Pref_Encl_Typ); while Present (E) @@ -3010,6 +3207,7 @@ package body Sem_Util is if E = S then return True; end if; + Next_Entity (E); end loop; end if; @@ -3036,7 +3234,7 @@ package body Sem_Util is and then No (Cont_Encl_Typ) and then Is_Public_Operation and then Scope_Depth (Pref_Encl_Typ) >= - Object_Access_Level (Context) + Object_Access_Level (Context) then Error_Msg_N ("??possible unprotected access to protected data", Expr); @@ -3044,18 +3242,6 @@ package body Sem_Util is end if; end Check_Unprotected_Access; - --------------- - -- Check_VMS -- - --------------- - - procedure Check_VMS (Construct : Node_Id) is - begin - if not OpenVMS_On_Target then - Error_Msg_N - ("this construct is allowed only in Open'V'M'S", Construct); - end if; - end Check_VMS; - ------------------------ -- Collect_Interfaces -- ------------------------ @@ -3113,9 +3299,7 @@ package body Sem_Util is Ancestor := Etype (Full_T); Collect (Ancestor); - if Is_Interface (Ancestor) - and then not Exclude_Parents - then + if Is_Interface (Ancestor) and then not Exclude_Parents then Append_Unique_Elmt (Ancestor, Ifaces_List); end if; end if; @@ -3259,8 +3443,8 @@ package body Sem_Util is end if; while Present (ADT) - and then Is_Tag (Node (ADT)) - and then Related_Type (Node (ADT)) /= Iface + and then Is_Tag (Node (ADT)) + and then Related_Type (Node (ADT)) /= Iface loop -- Skip secondary dispatch table referencing thunks to user -- defined primitives covered by this interface. @@ -3438,8 +3622,8 @@ package body Sem_Util is elsif Is_Generic_Type (B_Type) then if Nkind (B_Decl) = N_Formal_Type_Declaration - and then Nkind (Formal_Type_Definition (B_Decl)) - = N_Formal_Derived_Type_Definition + and then Nkind (Formal_Type_Definition (B_Decl)) = + N_Formal_Derived_Type_Definition then Formal_Derived := True; else @@ -3538,8 +3722,7 @@ package body Sem_Util is -- package declaration are not primitive for it. if Is_Prim - and then (not Formal_Derived - or else Present (Alias (Id))) + and then (not Formal_Derived or else Present (Alias (Id))) then -- In the special case of an equality operator aliased to -- an overriding dispatching equality belonging to the same @@ -3602,11 +3785,10 @@ package body Sem_Util is Msgl : Natural; Wmsg : Boolean; - P : Node_Id; - OldP : Node_Id; - Msgs : Boolean; Eloc : Source_Ptr; + -- Start of processing for Compile_Time_Constraint_Error + begin -- If this is a warning, convert it into an error if we are in code -- subject to SPARK_Mode being set ON. @@ -3677,82 +3859,12 @@ package body Sem_Util is Msgc (Msgl) := '!'; end if; - -- Should we generate a warning? The answer is not quite yes. The - -- very annoying exception occurs in the case of a short circuit - -- operator where the left operand is static and decisive. Climb - -- parents to see if that is the case we have here. Conditional - -- expressions with decisive conditions are a similar situation. - - Msgs := True; - P := N; - loop - OldP := P; - P := Parent (P); - - -- And then with False as left operand - - if Nkind (P) = N_And_Then - and then Compile_Time_Known_Value (Left_Opnd (P)) - and then Is_False (Expr_Value (Left_Opnd (P))) - then - Msgs := False; - exit; - - -- OR ELSE with True as left operand - - elsif Nkind (P) = N_Or_Else - and then Compile_Time_Known_Value (Left_Opnd (P)) - and then Is_True (Expr_Value (Left_Opnd (P))) - then - Msgs := False; - exit; - - -- If expression - - elsif Nkind (P) = N_If_Expression then - declare - Cond : constant Node_Id := First (Expressions (P)); - Texp : constant Node_Id := Next (Cond); - Fexp : constant Node_Id := Next (Texp); - - begin - if Compile_Time_Known_Value (Cond) then - - -- Condition is True and we are in the right operand - - if Is_True (Expr_Value (Cond)) - and then OldP = Fexp - then - Msgs := False; - exit; - - -- Condition is False and we are in the left operand - - elsif Is_False (Expr_Value (Cond)) - and then OldP = Texp - then - Msgs := False; - exit; - end if; - end if; - end; - - -- Special case for component association in aggregates, where - -- we want to keep climbing up to the parent aggregate. + -- One more test, skip the warning if the related expression is + -- statically unevaluated, since we don't want to warn about what + -- will happen when something is evaluated if it never will be + -- evaluated. - elsif Nkind (P) = N_Component_Association - and then Nkind (Parent (P)) = N_Aggregate - then - null; - - -- Keep going if within subexpression - - else - exit when Nkind (P) not in N_Subexpr; - end if; - end loop; - - if Msgs then + if not Is_Statically_Unevaluated (N) then Error_Msg_Warn := SPARK_Mode /= On; if Present (Ent) then @@ -4343,7 +4455,10 @@ package body Sem_Util is end if; end; - when N_Block_Statement => + when + N_Block_Statement | + N_Loop_Statement + => return Entity (Identifier (N)); when others => @@ -4361,10 +4476,9 @@ package body Sem_Util is Check_Concurrent : Boolean := False) return Boolean is E : Entity_Id; + begin - if not Is_Entity_Name (N) - or else No (Entity (N)) - then + if not Is_Entity_Name (N) or else No (Entity (N)) then return False; else E := Entity (N); @@ -4560,7 +4674,7 @@ package body Sem_Util is elsif Nkind (Obj1) = N_Selected_Component then return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) and then - Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); + Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2)); -- Both names are dereferences and the dereferenced names are known to -- denote the same object (RM 6.4.1(6.7/3)) @@ -4629,10 +4743,11 @@ package body Sem_Util is and then Denotes_Same_Object (Hi1, Hi2); end; - -- In the recursion, literals appear as indexes. + -- In the recursion, literals appear as indexes elsif Nkind (Obj1) = N_Integer_Literal - and then Nkind (Obj2) = N_Integer_Literal + and then + Nkind (Obj2) = N_Integer_Literal then return Intval (Obj1) = Intval (Obj2); @@ -4798,11 +4913,9 @@ package body Sem_Util is -- Start of processing for Designate_Next_Unit begin - if (K1 = N_Identifier or else - K1 = N_Defining_Identifier) - and then - (K2 = N_Identifier or else - K2 = N_Defining_Identifier) + if (K1 = N_Identifier or else K1 = N_Defining_Identifier) + and then + (K2 = N_Identifier or else K2 = N_Defining_Identifier) then return Chars (Name1) = Chars (Name2); @@ -5226,7 +5339,7 @@ package body Sem_Util is -- same name as a generic formal which has been seen already. elsif Nkind (Parent (Def_Id)) = N_Package_Renaming_Declaration - and then not Comes_From_Source (Def_Id) + and then not Comes_From_Source (Def_Id) then Set_Is_Immediately_Visible (E, False); @@ -5259,9 +5372,7 @@ package body Sem_Util is -- entity in the scope. Prev := First_Entity (Current_Scope); - while Present (Prev) - and then Next_Entity (Prev) /= E - loop + while Present (Prev) and then Next_Entity (Prev) /= E loop Next_Entity (Prev); end loop; @@ -5421,7 +5532,7 @@ package body Sem_Util is end if; if Nkind (Parent (Parent (Def_Id))) = - N_Generic_Subprogram_Declaration + N_Generic_Subprogram_Declaration and then Def_Id = Defining_Entity (Specification (Parent (Parent (Def_Id)))) then @@ -5489,9 +5600,7 @@ package body Sem_Util is -- Declaring a homonym is not allowed in SPARK ... - if Present (C) - and then Restriction_Check_Required (SPARK_05) - then + if Present (C) and then Restriction_Check_Required (SPARK_05) then declare Enclosing_Subp : constant Node_Id := Enclosing_Subprogram (Def_Id); Enclosing_Pack : constant Node_Id := Enclosing_Package (Def_Id); @@ -5529,7 +5638,7 @@ package body Sem_Util is and then Comes_From_Source (C) then Error_Msg_Sloc := Sloc (C); - Check_SPARK_Restriction + Check_SPARK_05_Restriction ("redeclaration of identifier &#", Def_Id); end if; end; @@ -5539,38 +5648,38 @@ package body Sem_Util is if Warn_On_Hiding and then Present (C) - -- Don't warn for record components since they always have a well - -- defined scope which does not confuse other uses. Note that in - -- some cases, Ekind has not been set yet. + -- Don't warn for record components since they always have a well + -- defined scope which does not confuse other uses. Note that in + -- some cases, Ekind has not been set yet. - and then Ekind (C) /= E_Component - and then Ekind (C) /= E_Discriminant - and then Nkind (Parent (C)) /= N_Component_Declaration - and then Ekind (Def_Id) /= E_Component - and then Ekind (Def_Id) /= E_Discriminant - and then Nkind (Parent (Def_Id)) /= N_Component_Declaration + and then Ekind (C) /= E_Component + and then Ekind (C) /= E_Discriminant + and then Nkind (Parent (C)) /= N_Component_Declaration + and then Ekind (Def_Id) /= E_Component + and then Ekind (Def_Id) /= E_Discriminant + and then Nkind (Parent (Def_Id)) /= N_Component_Declaration - -- Don't warn for one character variables. It is too common to use - -- such variables as locals and will just cause too many false hits. + -- Don't warn for one character variables. It is too common to use + -- such variables as locals and will just cause too many false hits. - and then Length_Of_Name (Chars (C)) /= 1 + and then Length_Of_Name (Chars (C)) /= 1 - -- Don't warn for non-source entities + -- Don't warn for non-source entities - and then Comes_From_Source (C) - and then Comes_From_Source (Def_Id) + and then Comes_From_Source (C) + and then Comes_From_Source (Def_Id) - -- Don't warn unless entity in question is in extended main source + -- Don't warn unless entity in question is in extended main source - and then In_Extended_Main_Source_Unit (Def_Id) + and then In_Extended_Main_Source_Unit (Def_Id) - -- Finally, the hidden entity must be either immediately visible or - -- use visible (i.e. from a used package). + -- Finally, the hidden entity must be either immediately visible or + -- use visible (i.e. from a used package). - and then - (Is_Immediately_Visible (C) - or else - Is_Potentially_Use_Visible (C)) + and then + (Is_Immediately_Visible (C) + or else + Is_Potentially_Use_Visible (C)) then Error_Msg_Sloc := Sloc (C); Error_Msg_N ("declaration hides &#?h?", Def_Id); @@ -5672,9 +5781,7 @@ package body Sem_Util is Actual : Node_Id; begin - if (Nkind (Parnt) = N_Indexed_Component - or else - Nkind (Parnt) = N_Selected_Component) + if Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component) and then N = Prefix (Parnt) then Find_Actual (Parnt, Formal, Call); @@ -5813,10 +5920,10 @@ package body Sem_Util is while Present (Old_Disc) and then Present (New_Disc) loop if Old_Disc = Par_Disc then return New_Disc; - else - Next_Discriminant (Old_Disc); - Next_Discriminant (New_Disc); end if; + + Next_Discriminant (Old_Disc); + Next_Discriminant (New_Disc); end loop; -- Should always find it @@ -6069,6 +6176,32 @@ package body Sem_Util is end loop; end Find_Placement_In_State_Space; + ------------------------ + -- Find_Specific_Type -- + ------------------------ + + function Find_Specific_Type (CW : Entity_Id) return Entity_Id is + Typ : Entity_Id := Root_Type (CW); + + begin + if Ekind (Typ) = E_Incomplete_Type then + if From_Limited_With (Typ) then + Typ := Non_Limited_View (Typ); + else + Typ := Full_View (Typ); + end if; + end if; + + if Is_Private_Type (Typ) + and then not Is_Tagged_Type (Typ) + and then Present (Full_View (Typ)) + then + return Full_View (Typ); + else + return Typ; + end if; + end Find_Specific_Type; + ----------------------------- -- Find_Static_Alternative -- ----------------------------- @@ -6104,8 +6237,7 @@ package body Sem_Util is -- be a static subtype, since otherwise it would have -- been diagnosed as illegal. - elsif Is_Entity_Name (Choice) - and then Is_Type (Entity (Choice)) + elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)) then exit Search when Is_In_Range (Expr, Etype (Choice), Assume_Valid => False); @@ -6119,7 +6251,7 @@ package body Sem_Util is begin exit Search when - Val >= Expr_Value (Low_Bound (R)) + Val >= Expr_Value (Low_Bound (R)) and then Val <= Expr_Value (High_Bound (R)); end; @@ -6211,9 +6343,7 @@ package body Sem_Util is declare Comp : constant Entity_Id := Defining_Identifier (Comp_Item); begin - if not Is_Tag (Comp) - and then Chars (Comp) /= Name_uParent - then + if not Is_Tag (Comp) and then Chars (Comp) /= Name_uParent then Append_Elmt (Comp, Into); end if; end; @@ -6873,6 +7003,23 @@ package body Sem_Util is return Strval (Expr_Value_S (Arg)); end Get_Name_From_CTC_Pragma; + ----------------------- + -- Get_Parent_Entity -- + ----------------------- + + function Get_Parent_Entity (Unit : Node_Id) return Entity_Id is + begin + if Nkind (Unit) = N_Package_Body + and then Nkind (Original_Node (Unit)) = N_Package_Instantiation + then + return Defining_Entity + (Specification (Instance_Spec (Original_Node (Unit)))); + elsif Nkind (Unit) = N_Package_Instantiation then + return Defining_Entity (Specification (Instance_Spec (Unit))); + else + return Defining_Entity (Unit); + end if; + end Get_Parent_Entity; ------------------- -- Get_Pragma_Id -- ------------------- @@ -7393,8 +7540,7 @@ package body Sem_Util is -- where we do not know the alignment of Obj. if Known_Alignment (Entity (Expr)) - and then - UI_To_Int (Alignment (Entity (Expr))) < + and then UI_To_Int (Alignment (Entity (Expr))) < Ttypes.Maximum_Alignment then Set_Result (Unknown); @@ -7476,15 +7622,25 @@ package body Sem_Util is N_Package_Specification); end Has_Declarations; + --------------------------------- + -- Has_Defaulted_Discriminants -- + --------------------------------- + + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean is + begin + return Has_Discriminants (Typ) + and then Present (First_Discriminant (Typ)) + and then Present (Discriminant_Default_Value + (First_Discriminant (Typ))); + end Has_Defaulted_Discriminants; + ------------------- -- Has_Denormals -- ------------------- function Has_Denormals (E : Entity_Id) return Boolean is begin - return Is_Floating_Point_Type (E) - and then Denorm_On_Target - and then not Vax_Float (E); + return Is_Floating_Point_Type (E) and then Denorm_On_Target; end Has_Denormals; ------------------------------------------- @@ -7550,10 +7706,11 @@ package body Sem_Util is Property : Name_Id) return Boolean is function State_Has_Enabled_Property return Boolean; - -- Determine whether a state denoted by Item_Id has the property + -- Determine whether a state denoted by Item_Id has the property enabled function Variable_Has_Enabled_Property return Boolean; -- Determine whether a variable denoted by Item_Id has the property + -- enabled. -------------------------------- -- State_Has_Enabled_Property -- @@ -7629,7 +7786,7 @@ package body Sem_Util is if Nkind (Prop_Nam) = N_Others_Choice or else (Nkind (Prop_Nam) = N_Identifier - and then Chars (Prop_Nam) = Property) + and then Chars (Prop_Nam) = Property) then return Is_True (Expr_Value (Expression (Prop))); end if; @@ -7655,6 +7812,44 @@ package body Sem_Util is ----------------------------------- function Variable_Has_Enabled_Property return Boolean is + function Is_Enabled (Prag : Node_Id) return Boolean; + -- Determine whether property pragma Prag (if present) denotes an + -- enabled property. + + ---------------- + -- Is_Enabled -- + ---------------- + + function Is_Enabled (Prag : Node_Id) return Boolean is + Arg2 : Node_Id; + + begin + if Present (Prag) then + Arg2 := Next (First (Pragma_Argument_Associations (Prag))); + + -- The pragma has an optional Boolean expression, the related + -- property is enabled only when the expression evaluates to + -- True. + + if Present (Arg2) then + return Is_True (Expr_Value (Get_Pragma_Arg (Arg2))); + + -- Otherwise the lack of expression enables the property by + -- default. + + else + return True; + end if; + + -- The property was never set in the first place + + else + return False; + end if; + end Is_Enabled; + + -- Local variables + AR : constant Node_Id := Get_Pragma (Item_Id, Pragma_Async_Readers); AW : constant Node_Id := @@ -7663,45 +7858,37 @@ package body Sem_Util is Get_Pragma (Item_Id, Pragma_Effective_Reads); EW : constant Node_Id := Get_Pragma (Item_Id, Pragma_Effective_Writes); + + -- Start of processing for Variable_Has_Enabled_Property + begin - -- A non-volatile object can never possess external properties + -- A non-effectively volatile object can never possess external + -- properties. - if not Is_SPARK_Volatile (Item_Id) then + if not Is_Effectively_Volatile (Item_Id) then return False; -- External properties related to variables come in two flavors - -- explicit and implicit. The explicit case is characterized by the - -- presence of a property pragma while the implicit case lacks all - -- such pragmas. + -- presence of a property pragma with an optional Boolean flag. The + -- property is enabled when the flag evaluates to True or the flag is + -- missing altogether. - elsif Property = Name_Async_Readers - and then - (Present (AR) - or else - (No (AW) and then No (ER) and then No (EW))) - then + elsif Property = Name_Async_Readers and then Is_Enabled (AR) then return True; - elsif Property = Name_Async_Writers - and then - (Present (AW) - or else - (No (AR) and then No (ER) and then No (EW))) - then + elsif Property = Name_Async_Writers and then Is_Enabled (AW) then return True; - elsif Property = Name_Effective_Reads - and then - (Present (ER) - or else - (No (AR) and then No (AW) and then No (EW))) - then + elsif Property = Name_Effective_Reads and then Is_Enabled (ER) then return True; - elsif Property = Name_Effective_Writes - and then - (Present (EW) or else (No (AR) and then No (AW) and then No (ER))) - then + elsif Property = Name_Effective_Writes and then Is_Enabled (EW) then + return True; + + -- 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; else @@ -7721,10 +7908,11 @@ package body Sem_Util is elsif Ekind (Item_Id) = E_Variable then return Variable_Has_Enabled_Property; - -- Otherwise a property is enabled when the related object is volatile + -- Otherwise a property is enabled when the related item is effectively + -- volatile. else - return Is_SPARK_Volatile (Item_Id); + return Is_Effectively_Volatile (Item_Id); end if; end Has_Enabled_Property; @@ -7766,9 +7954,7 @@ package body Sem_Util is -- Handle private types - if Use_Full_View - and then Present (Full_View (Typ)) - then + if Use_Full_View and then Present (Full_View (Typ)) then Typ := Full_View (Typ); end if; @@ -7795,10 +7981,9 @@ package body Sem_Util is -- Handle private types or else (Present (Full_View (Etype (Typ))) - and then Full_View (Etype (Typ)) = Typ) + and then Full_View (Etype (Typ)) = Typ) - -- Protect the frontend against wrong source with cyclic - -- derivations + -- Protect frontend against wrong sources with cyclic derivations or else Etype (Typ) = T; @@ -7834,13 +8019,12 @@ package body Sem_Util is return Has_No_Obvious_Side_Effects (Right_Opnd (N)); elsif Nkind (N) in N_Binary_Op or else Nkind (N) in N_Short_Circuit then - return Has_No_Obvious_Side_Effects (Left_Opnd (N)) - and then + return Has_No_Obvious_Side_Effects (Left_Opnd (N)) + and then Has_No_Obvious_Side_Effects (Right_Opnd (N)); elsif Nkind (N) = N_Expression_With_Actions - and then - Is_Empty_List (Actions (N)) + and then Is_Empty_List (Actions (N)) then return Has_No_Obvious_Side_Effects (Expression (N)); @@ -7970,13 +8154,13 @@ package body Sem_Util is Formal : constant Entity_Id := First_Formal (Init); begin if Ekind (Init) = E_Procedure - and then Chars (Init) = Name_Initialize - and then Comes_From_Source (Init) - and then Present (Formal) - and then Etype (Formal) = BT - and then No (Next_Formal (Formal)) - and then (Ada_Version < Ada_2012 - or else not Null_Present (Parent (Init))) + and then Chars (Init) = Name_Initialize + and then Comes_From_Source (Init) + and then Present (Formal) + and then Etype (Formal) = BT + and then No (Next_Formal (Formal)) + and then (Ada_Version < Ada_2012 + or else not Null_Present (Parent (Init))) then return True; end if; @@ -8034,7 +8218,7 @@ package body Sem_Util is Is_Array_Aggr : Boolean; begin - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then return True; elsif Nkind (N) = N_Null then @@ -8124,11 +8308,11 @@ package body Sem_Util is null; elsif Nkind (Choice) = N_Range then - if not Is_Static_Range (Choice) then + if not Is_OK_Static_Range (Choice) then return False; end if; - elsif not Is_Static_Expression (Choice) then + elsif not Is_OK_Static_Expression (Choice) then return False; end if; @@ -8290,10 +8474,13 @@ package body Sem_Util is end if; -- Check specifically for 10.2.1(11.4/2) exception: a controlled type - -- with a user defined Initialize procedure does not have PI. + -- with a user defined Initialize procedure does not have PI. If + -- the type is untagged, the control primitives come from a component + -- that has already been checked. if Has_PE and then Is_Controlled (E) + and then Is_Tagged_Type (E) and then Has_Overriding_Initialize (E) then Has_PE := False; @@ -8410,9 +8597,7 @@ package body Sem_Util is function Has_Signed_Zeros (E : Entity_Id) return Boolean is begin - return Is_Floating_Point_Type (E) - and then Signed_Zeros_On_Target - and then not Vax_Float (E); + return Is_Floating_Point_Type (E) and then Signed_Zeros_On_Target; end Has_Signed_Zeros; ----------------------------- @@ -8733,9 +8918,7 @@ package body Sem_Util is begin S := Current_Scope; - while Present (S) - and then S /= Standard_Standard - loop + while Present (S) and then S /= Standard_Standard loop if (Ekind (S) = E_Function or else Ekind (S) = E_Package or else Ekind (S) = E_Procedure) @@ -8748,9 +8931,8 @@ package body Sem_Util is -- that it is not currently on the scope stack. if Is_Child_Unit (Curr_Unit) - and then - Nkind (Unit (Cunit (Current_Sem_Unit))) - = N_Package_Instantiation + and then Nkind (Unit (Cunit (Current_Sem_Unit))) = + N_Package_Instantiation and then not In_Open_Scopes (Curr_Unit) then return False; @@ -8774,11 +8956,8 @@ package body Sem_Util is begin S := Current_Scope; - while Present (S) - and then S /= Standard_Standard - loop - if (Ekind (S) = E_Function - or else Ekind (S) = E_Procedure) + while Present (S) and then S /= Standard_Standard loop + if Ekind_In (S, E_Function, E_Procedure) and then Is_Generic_Instance (S) then return True; @@ -8805,11 +8984,8 @@ package body Sem_Util is begin S := Current_Scope; - while Present (S) - and then S /= Standard_Standard - loop - if (Ekind (S) = E_Function - or else Ekind (S) = E_Procedure) + while Present (S) and then S /= Standard_Standard loop + if Ekind_In (S, E_Function, E_Procedure) and then Is_Generic_Instance (S) then return True; @@ -8836,9 +9012,7 @@ package body Sem_Util is begin S := Current_Scope; - while Present (S) - and then S /= Standard_Standard - loop + while Present (S) and then S /= Standard_Standard loop if Ekind (S) = E_Package and then Is_Generic_Instance (S) and then not In_Package_Body (S) @@ -8862,12 +9036,8 @@ package body Sem_Util is begin S := Current_Scope; - while Present (S) - and then S /= Standard_Standard - loop - if Ekind (S) = E_Package - and then In_Package_Body (S) - then + while Present (S) and then S /= Standard_Standard loop + if Ekind (S) = E_Package and then In_Package_Body (S) then return True; else S := Scope (S); @@ -8947,10 +9117,9 @@ package body Sem_Util is Btyp := Base_Type (Etype (Pref)); end if; - return - Present (Btyp) - and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) - and then Reverse_Storage_Order (Btyp); + return Present (Btyp) + and then (Is_Record_Type (Btyp) or else Is_Array_Type (Btyp)) + and then Reverse_Storage_Order (Btyp); end In_Reverse_Storage_Order_Object; -------------------------------------- @@ -8988,11 +9157,10 @@ package body Sem_Util is function In_Visible_Part (Scope_Id : Entity_Id) return Boolean is begin - return - Is_Package_Or_Generic_Package (Scope_Id) - and then In_Open_Scopes (Scope_Id) - and then not In_Package_Body (Scope_Id) - and then not In_Private_Part (Scope_Id); + return Is_Package_Or_Generic_Package (Scope_Id) + and then In_Open_Scopes (Scope_Id) + and then not In_Package_Body (Scope_Id) + and then not In_Private_Part (Scope_Id); end In_Visible_Part; -------------------------------- @@ -9110,6 +9278,23 @@ package body Sem_Util is return Empty; end Incomplete_Or_Private_View; + ----------------------------------------- + -- Inherit_Default_Init_Cond_Procedure -- + ----------------------------------------- + + procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is + Par_Typ : constant Entity_Id := Etype (Typ); + + begin + -- A derived type inherits the default initial condition procedure of + -- its parent type. + + if No (Default_Init_Cond_Procedure (Typ)) then + Set_Default_Init_Cond_Procedure + (Typ, Default_Init_Cond_Procedure (Par_Typ)); + end if; + end Inherit_Default_Init_Cond_Procedure; + --------------------------------- -- Insert_Explicit_Dereference -- --------------------------------- @@ -9163,14 +9348,13 @@ package body Sem_Util is -- For a retrieval of a subcomponent of some composite object, -- retrieve the ultimate entity if there is one. - elsif Nkind (New_Prefix) = N_Selected_Component - or else Nkind (New_Prefix) = N_Indexed_Component + elsif Nkind_In (New_Prefix, N_Selected_Component, + N_Indexed_Component) then Pref := Prefix (New_Prefix); while Present (Pref) - and then - (Nkind (Pref) = N_Selected_Component - or else Nkind (Pref) = N_Indexed_Component) + and then Nkind_In (Pref, N_Selected_Component, + N_Indexed_Component) loop Pref := Prefix (Pref); end loop; @@ -9346,9 +9530,7 @@ package body Sem_Util is begin Par := E2; - while Present (Par) - and then Par /= Standard_Standard - loop + while Present (Par) and then Par /= Standard_Standard loop if Par = E1 then return True; end if; @@ -9451,9 +9633,8 @@ package body Sem_Util is function Is_Attribute_Result (N : Node_Id) return Boolean is begin - return - Nkind (N) = N_Attribute_Reference - and then Attribute_Name (N) = Name_Result; + return Nkind (N) = N_Attribute_Reference + and then Attribute_Name (N) = Name_Result; end Is_Attribute_Result; ------------------------------------ @@ -9652,9 +9833,8 @@ package body Sem_Util is function Is_Concurrent_Interface (T : Entity_Id) return Boolean is begin - return - Is_Interface (T) - and then + return Is_Interface (T) + and then (Is_Protected_Interface (T) or else Is_Synchronized_Interface (T) or else Is_Task_Interface (T)); @@ -10100,7 +10280,7 @@ package body Sem_Util is and then In_Package_Body (Current_Scope))) and then (Is_Declared_Within_Variant (Comp) - or else Has_Discriminant_Dependent_Constraint (Comp)) + or else Has_Discriminant_Dependent_Constraint (Comp)) and then (not P_Aliased or else Ada_Version >= Ada_2005) then return True; @@ -10145,14 +10325,10 @@ package body Sem_Util is function Is_Dereferenced (N : Node_Id) return Boolean is P : constant Node_Id := Parent (N); begin - return - (Nkind (P) = N_Selected_Component - or else - Nkind (P) = N_Explicit_Dereference - or else - Nkind (P) = N_Indexed_Component - or else - Nkind (P) = N_Slice) + return Nkind_In (P, N_Selected_Component, + N_Explicit_Dereference, + N_Indexed_Component, + N_Slice) and then Prefix (P) = N; end Is_Dereferenced; @@ -10215,6 +10391,70 @@ package body Sem_Util is end if; end Is_Descendent_Of; + ----------------------------- + -- Is_Effectively_Volatile -- + ----------------------------- + + function Is_Effectively_Volatile (Id : Entity_Id) return Boolean is + begin + if Is_Type (Id) then + + -- An arbitrary type is effectively volatile when it is subject to + -- pragma Atomic or Volatile. + + if Is_Volatile (Id) then + return True; + + -- An array type is effectively volatile when it is subject to pragma + -- Atomic_Components or Volatile_Components or its compolent type is + -- effectively volatile. + + elsif Is_Array_Type (Id) then + return + Has_Volatile_Components (Id) + or else + Is_Effectively_Volatile (Component_Type (Base_Type (Id))); + + else + return False; + end if; + + -- Otherwise Id denotes an object + + else + return + Is_Volatile (Id) + or else Has_Volatile_Components (Id) + or else Is_Effectively_Volatile (Etype (Id)); + end if; + end Is_Effectively_Volatile; + + ------------------------------------ + -- Is_Effectively_Volatile_Object -- + ------------------------------------ + + function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean is + begin + 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)); + + elsif Nkind (N) = N_Selected_Component then + return + Is_Effectively_Volatile_Object (Prefix (N)) + or else + Is_Effectively_Volatile_Object (Selector_Name (N)); + + else + return False; + end if; + end Is_Effectively_Volatile_Object; + ---------------------------- -- Is_Expression_Function -- ---------------------------- @@ -10325,7 +10565,8 @@ package body Sem_Util is end if; if Compile_Time_Known_Value (Lbd) - and then Compile_Time_Known_Value (Hbd) + and then + Compile_Time_Known_Value (Hbd) then if Expr_Value (Hbd) < Expr_Value (Lbd) then return True; @@ -10407,7 +10648,7 @@ package body Sem_Util is while Present (Ent) loop if Ekind (Ent) = E_Component and then (No (Parent (Ent)) - or else No (Expression (Parent (Ent)))) + or else No (Expression (Parent (Ent)))) and then not Is_Fully_Initialized_Type (Etype (Ent)) -- Special VM case for tag components, which need to be @@ -10584,9 +10825,8 @@ package body Sem_Util is begin if Is_Class_Wide_Type (Typ) - and then - Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, - Name_Reversible_Iterator) + and then Nam_In (Chars (Etype (Typ)), Name_Forward_Iterator, + Name_Reversible_Iterator) and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) @@ -10620,45 +10860,6 @@ package body Sem_Util is end if; end Is_Iterator; - ------------------ - -- Is_Junk_Name -- - ------------------ - - function Is_Junk_Name (N : Name_Id) return Boolean is - function Match (S : String) return Boolean; - -- Return true if substring S is found in Name_Buffer (1 .. Name_Len) - - ----------- - -- Match -- - ----------- - - function Match (S : String) return Boolean is - Slen1 : constant Integer := S'Length - 1; - - begin - for J in 1 .. Name_Len - S'Length + 1 loop - if Name_Buffer (J .. J + Slen1) = S then - return True; - end if; - end loop; - - return False; - end Match; - - -- Start of processing for Is_Junk_Name - - begin - Get_Unqualified_Decoded_Name_String (N); - Set_All_Upper_Case; - - return - Match ("DISCARD") or else - Match ("DUMMY") or else - Match ("IGNORE") or else - Match ("JUNK") or else - Match ("UNUSED"); - end Is_Junk_Name; - ------------ -- Is_LHS -- ------------ @@ -10830,7 +11031,7 @@ package body Sem_Util is Is_Object_Reference (Selector_Name (N)) and then (Is_Object_Reference (Prefix (N)) - or else Is_Access_Type (Etype (Prefix (N)))); + or else Is_Access_Type (Etype (Prefix (N)))); when N_Explicit_Dereference => return True; @@ -11174,6 +11375,17 @@ package body Sem_Util is begin Expr := N; Par := Parent (N); + + -- A postcondition whose expression is a short-circuit is broken down + -- into individual aspects for better exception reporting. The original + -- short-circuit expression is rewritten as the second operand, and an + -- occurrence of 'Old in that operand is potentially unevaluated. + -- See Sem_ch13.adb for details of this transformation. + + if Nkind (Original_Node (Par)) = N_And_Then then + return True; + end if; + while not Nkind_In (Par, N_If_Expression, N_Case_Expression, N_And_Then, @@ -11350,7 +11562,7 @@ package body Sem_Util is elsif Present (Controlling_Argument (N)) and then Is_Remote_Access_To_Class_Wide_Type - (Etype (Controlling_Argument (N))) + (Etype (Controlling_Argument (N))) then -- Any primitive operation call with a controlling argument of -- a RACW type is a remote call. @@ -11426,16 +11638,13 @@ package body Sem_Util is begin if Is_Class_Wide_Type (Typ) - and then Chars (Etype (Typ)) = Name_Reversible_Iterator - and then - Is_Predefined_File_Name - (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) + and then Chars (Etype (Typ)) = Name_Reversible_Iterator + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Etype (Typ)))) then return True; - elsif not Is_Tagged_Type (Typ) - or else not Is_Derived_Type (Typ) - then + elsif not Is_Tagged_Type (Typ) or else not Is_Derived_Type (Typ) then return False; else @@ -11468,13 +11677,11 @@ package body Sem_Util is if not Is_List_Member (N) then declare P : constant Node_Id := Parent (N); - K : constant Node_Kind := Nkind (P); begin - return - (K = N_Expanded_Name or else - K = N_Generic_Association or else - K = N_Parameter_Association or else - K = N_Selected_Component) + return Nkind_In (P, N_Expanded_Name, + N_Generic_Association, + N_Parameter_Association, + N_Selected_Component) and then Selector_Name (P) = N; end; @@ -11492,11 +11699,11 @@ package body Sem_Util is end if; end Is_Selector_Name; - ---------------------------------- - -- Is_SPARK_Initialization_Expr -- - ---------------------------------- + ------------------------------------- + -- Is_SPARK_05_Initialization_Expr -- + ------------------------------------- - function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean is + function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean is Is_Ok : Boolean; Expr : Node_Id; Comp_Assn : Node_Id; @@ -11540,26 +11747,28 @@ package body Sem_Util is when N_Qualified_Expression | N_Type_Conversion => - Is_Ok := Is_SPARK_Initialization_Expr (Expression (Orig_N)); + Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N)); when N_Unary_Op => - Is_Ok := Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); + Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N)); when N_Binary_Op | N_Short_Circuit | N_Membership_Test => - Is_Ok := Is_SPARK_Initialization_Expr (Left_Opnd (Orig_N)) - and then Is_SPARK_Initialization_Expr (Right_Opnd (Orig_N)); + 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 => if Nkind (Orig_N) = N_Extension_Aggregate then - Is_Ok := Is_SPARK_Initialization_Expr (Ancestor_Part (Orig_N)); + Is_Ok := + Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N)); end if; Expr := First (Expressions (Orig_N)); while Present (Expr) loop - if not Is_SPARK_Initialization_Expr (Expr) then + if not Is_SPARK_05_Initialization_Expr (Expr) then Is_Ok := False; goto Done; end if; @@ -11571,7 +11780,7 @@ package body Sem_Util is while Present (Comp_Assn) loop Expr := Expression (Comp_Assn); if Present (Expr) -- needed for box association - and then not Is_SPARK_Initialization_Expr (Expr) + and then not Is_SPARK_05_Initialization_Expr (Expr) then Is_Ok := False; goto Done; @@ -11582,12 +11791,12 @@ package body Sem_Util is when N_Attribute_Reference => if Nkind (Prefix (Orig_N)) in N_Subexpr then - Is_Ok := Is_SPARK_Initialization_Expr (Prefix (Orig_N)); + Is_Ok := Is_SPARK_05_Initialization_Expr (Prefix (Orig_N)); end if; Expr := First (Expressions (Orig_N)); while Present (Expr) loop - if not Is_SPARK_Initialization_Expr (Expr) then + if not Is_SPARK_05_Initialization_Expr (Expr) then Is_Ok := False; goto Done; end if; @@ -11607,65 +11816,30 @@ package body Sem_Util is <> return Is_Ok; - end Is_SPARK_Initialization_Expr; + end Is_SPARK_05_Initialization_Expr; - ------------------------------- - -- Is_SPARK_Object_Reference -- - ------------------------------- + ---------------------------------- + -- Is_SPARK_05_Object_Reference -- + ---------------------------------- - function Is_SPARK_Object_Reference (N : Node_Id) return Boolean is + function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean is begin if Is_Entity_Name (N) then return Present (Entity (N)) and then (Ekind_In (Entity (N), E_Constant, E_Variable) - or else Ekind (Entity (N)) in Formal_Kind); + or else Ekind (Entity (N)) in Formal_Kind); else case Nkind (N) is when N_Selected_Component => - return Is_SPARK_Object_Reference (Prefix (N)); + return Is_SPARK_05_Object_Reference (Prefix (N)); when others => return False; end case; end if; - end Is_SPARK_Object_Reference; - - ----------------------- - -- Is_SPARK_Volatile -- - ----------------------- - - function Is_SPARK_Volatile (Id : Entity_Id) return Boolean is - begin - return Is_Volatile (Id) or else Is_Volatile (Etype (Id)); - end Is_SPARK_Volatile; - - ------------------------------ - -- Is_SPARK_Volatile_Object -- - ------------------------------ - - function Is_SPARK_Volatile_Object (N : Node_Id) return Boolean is - begin - if Is_Entity_Name (N) then - return Is_SPARK_Volatile (Entity (N)); - - elsif Nkind (N) = N_Expanded_Name then - return Is_SPARK_Volatile (Entity (N)); - - elsif Nkind (N) = N_Indexed_Component then - return Is_SPARK_Volatile_Object (Prefix (N)); - - elsif Nkind (N) = N_Selected_Component then - return - Is_SPARK_Volatile_Object (Prefix (N)) - or else - Is_SPARK_Volatile_Object (Selector_Name (N)); - - else - return False; - end if; - end Is_SPARK_Volatile_Object; + end Is_SPARK_05_Object_Reference; ------------------ -- Is_Statement -- @@ -11878,25 +12052,6 @@ package body Sem_Util is return False; end Is_Variable_Size_Record; - --------------------- - -- Is_VMS_Operator -- - --------------------- - - function Is_VMS_Operator (Op : Entity_Id) return Boolean is - begin - -- The VMS operators are declared in a child of System that is loaded - -- through pragma Extend_System. In some rare cases a program is run - -- with this extension but without indicating that the target is VMS. - - return Ekind (Op) = E_Function - and then Is_Intrinsic_Subprogram (Op) - and then - ((Present_System_Aux and then Scope (Op) = System_Aux_Id) - or else - (True_VMS_Target - and then Scope (Scope (Op)) = RTU_Entity (System))); - end Is_VMS_Operator; - ----------------- -- Is_Variable -- ----------------- @@ -12033,7 +12188,7 @@ package body Sem_Util is elsif Nkind (N) = N_Explicit_Dereference and then Present (Etype (Orig_Node)) - and then Ada_Version >= Ada_2012 + and then Ada_Version >= Ada_2012 and then Has_Implicit_Dereference (Etype (Orig_Node)) then return True; @@ -12053,10 +12208,10 @@ package body Sem_Util is K : constant Entity_Kind := Ekind (E); begin - return (K = E_Variable - and then Nkind (Parent (E)) /= N_Exception_Handler) + return (K = E_Variable + and then Nkind (Parent (E)) /= N_Exception_Handler) or else (K = E_Component - and then not In_Protected_Function (E)) + and then not In_Protected_Function (E)) or else K = E_Out_Parameter or else K = E_In_Out_Parameter or else K = E_Generic_In_Out_Parameter @@ -12528,8 +12683,9 @@ package body Sem_Util is L_Index := First_Index (L_Typ); Get_Index_Bounds (L_Index, L_Low, L_High); - if Is_OK_Static_Expression (L_Low) - and then Is_OK_Static_Expression (L_High) + if Is_OK_Static_Expression (L_Low) + and then + Is_OK_Static_Expression (L_High) then if Expr_Value (L_High) < Expr_Value (L_Low) then L_Len := Uint_0; @@ -12548,8 +12704,9 @@ package body Sem_Util is R_Index := First_Index (R_Typ); Get_Index_Bounds (R_Index, R_Low, R_High); - if Is_OK_Static_Expression (R_Low) - and then Is_OK_Static_Expression (R_High) + if Is_OK_Static_Expression (R_Low) + and then + Is_OK_Static_Expression (R_High) then if Expr_Value (R_High) < Expr_Value (R_Low) then R_Len := Uint_0; @@ -12561,8 +12718,9 @@ package body Sem_Util is end if; end if; - if Is_OK_Static_Expression (L_Low) - and then Is_OK_Static_Expression (R_Low) + if (Is_OK_Static_Expression (L_Low) + and then + Is_OK_Static_Expression (R_Low)) and then Expr_Value (L_Low) = Expr_Value (R_Low) and then L_Len = R_Len then @@ -12580,12 +12738,13 @@ package body Sem_Util is Get_Index_Bounds (L_Index, L_Low, L_High); Get_Index_Bounds (R_Index, R_Low, R_High); - if Is_OK_Static_Expression (L_Low) - and then Is_OK_Static_Expression (L_High) - and then Is_OK_Static_Expression (R_Low) - and then Is_OK_Static_Expression (R_High) - and then Expr_Value (L_Low) = Expr_Value (R_Low) - and then Expr_Value (L_High) = Expr_Value (R_High) + if (Is_OK_Static_Expression (L_Low) and then + Is_OK_Static_Expression (L_High) and then + Is_OK_Static_Expression (R_Low) and then + Is_OK_Static_Expression (R_High)) + and then (Expr_Value (L_Low) = Expr_Value (R_Low) + and then + Expr_Value (L_High) = Expr_Value (R_High)) then null; else @@ -13578,9 +13737,7 @@ package body Sem_Util is end; end if; - elsif F in List_Range - and then Parent (List_Id (F)) = N - then + elsif F in List_Range and then Parent (List_Id (F)) = N then Visit_List (List_Id (F)); return; end if; @@ -13656,8 +13813,7 @@ package body Sem_Util is end if; if Is_Type (Node (E)) - and then - Old_Itype = Associated_Node_For_Itype (Node (E)) + and then Old_Itype = Associated_Node_For_Itype (Node (E)) then Set_Associated_Node_For_Itype (Node (Next_Elmt (E)), New_Itype); @@ -13753,9 +13909,8 @@ package body Sem_Util is begin -- Handle case of an Itype, which must be copied - if Has_Extension (N) - and then Is_Itype (N) - then + if Has_Extension (N) 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. @@ -13949,34 +14104,6 @@ package body Sem_Util is Actual_Id := Next_Actual (Actual_Id); end Next_Actual; - --------------------- - -- No_Scalar_Parts -- - --------------------- - - function No_Scalar_Parts (T : Entity_Id) return Boolean is - C : Entity_Id; - - begin - if Is_Scalar_Type (T) then - return False; - - elsif Is_Array_Type (T) then - return No_Scalar_Parts (Component_Type (T)); - - elsif Is_Record_Type (T) or else Has_Discriminants (T) then - C := First_Component_Or_Discriminant (T); - while Present (C) loop - if not No_Scalar_Parts (Etype (C)) then - return False; - else - Next_Component_Or_Discriminant (C); - end if; - end loop; - end if; - - return True; - end No_Scalar_Parts; - ----------------------- -- Normalize_Actuals -- ----------------------- @@ -14187,14 +14314,13 @@ package body Sem_Util is then if No (Actuals) and then - (Nkind (Parent (N)) = N_Procedure_Call_Statement - or else - (Nkind (Parent (N)) = N_Function_Call - or else - Nkind (Parent (N)) = N_Parameter_Association)) + Nkind_In (Parent (N), N_Procedure_Call_Statement, + N_Function_Call, + N_Parameter_Association) and then Ekind (S) /= E_Function then Set_Etype (N, Etype (S)); + else Error_Msg_Name_1 := Chars (S); Error_Msg_Sloc := Sloc (S); @@ -14433,8 +14559,7 @@ package body Sem_Util is -- or container is also modified. if Ada_Version >= Ada_2012 - and then - Nkind (Parent (Ent)) = N_Iterator_Specification + and then Nkind (Parent (Ent)) = N_Iterator_Specification then declare Domain : constant Node_Id := Name (Parent (Ent)); @@ -14461,8 +14586,7 @@ package body Sem_Util is -- this modifies a constant, then give an appropriate warning. if Overlays_Constant (Ent) - and then Modification_Comes_From_Source - and then Sure + and then (Modification_Comes_From_Source and Sure) then declare A : constant Node_Id := Address_Clause (Ent); @@ -14525,10 +14649,9 @@ package body Sem_Util is function Is_Interface_Conversion (N : Node_Id) return Boolean is begin - return - Nkind (N) = N_Unchecked_Type_Conversion - and then Nkind (Expression (N)) = N_Attribute_Reference - and then Attribute_Name (Expression (N)) = Name_Address; + return Nkind (N) = N_Unchecked_Type_Conversion + and then Nkind (Expression (N)) = N_Attribute_Reference + and then Attribute_Name (Expression (N)) = Name_Address; end Is_Interface_Conversion; ------------------ @@ -14593,7 +14716,15 @@ package body Sem_Util is return Type_Access_Level (Scope (E)) + 1; else - return Scope_Depth (Enclosing_Dynamic_Scope (E)); + -- Aliased formals take their access level from the point of call. + -- This is smaller than the level of the subprogram itself. + + if Is_Formal (E) and then Is_Aliased (E) then + return Type_Access_Level (Etype (E)); + + else + return Scope_Depth (Enclosing_Dynamic_Scope (E)); + end if; end if; elsif Nkind (Obj) = N_Selected_Component then @@ -14765,6 +14896,12 @@ package body Sem_Util is elsif Nkind (Obj) = N_Qualified_Expression then return Object_Access_Level (Expression (Obj)); + -- Ditto for aggregates. They have the level of the temporary that + -- will hold their value. + + elsif Nkind (Obj) = N_Aggregate then + return Object_Access_Level (Current_Scope); + -- Otherwise return the scope level of Standard. (If there are cases -- that fall through to this point they will be treated as having -- global accessibility for now. ???) @@ -14870,6 +15007,54 @@ package body Sem_Util is end if; end Original_Corresponding_Operation; + ---------------------------------- + -- Predicate_Tests_On_Arguments -- + ---------------------------------- + + function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean is + begin + -- Always test predicates on indirect call + + if Ekind (Subp) = E_Subprogram_Type then + return True; + + -- Do not test predicates on call to generated default Finalize, since + -- we are not interested in whether something we are finalizing (and + -- typically destroying) satisfies its predicates. + + elsif Chars (Subp) = Name_Finalize + and then not Comes_From_Source (Subp) + then + return False; + + -- Do not test predicates on any internally generated routines + + elsif Is_Internal_Name (Chars (Subp)) then + return False; + + -- Do not test predicates on call to Init_Proc, since if needed the + -- predicate test will occur at some other point. + + elsif Is_Init_Proc (Subp) then + return False; + + -- Do not test predicates on call to predicate function, since this + -- would cause infinite recursion. + + elsif Ekind (Subp) = E_Function + and then (Is_Predicate_Function (Subp) + or else + Is_Predicate_Function_M (Subp)) + then + return False; + + -- For now, no other exceptions + + else + return True; + end if; + end Predicate_Tests_On_Arguments; + ----------------------- -- Private_Component -- ----------------------- @@ -14902,9 +15087,7 @@ package body Sem_Util is return Any_Type; end if; - if Is_Private_Type (Btype) - and then not Is_Generic_Type (Btype) - then + if Is_Private_Type (Btype) and then not Is_Generic_Type (Btype) then if Present (Full_View (Btype)) and then Is_Record_Type (Full_View (Btype)) and then not Is_Frozen (Btype) @@ -14991,16 +15174,16 @@ package body Sem_Util is return Chars (E1) = Chars (E2) or else (not Is_Internal_Name (Chars (E1)) - and then Is_Internal_Name (Chars (E2)) - and then Non_Internal_Name (E2) = Chars (E1)) + and then Is_Internal_Name (Chars (E2)) + and then Non_Internal_Name (E2) = Chars (E1)) or else (not Is_Internal_Name (Chars (E2)) - and then Is_Internal_Name (Chars (E1)) - and then Non_Internal_Name (E1) = Chars (E2)) + and then Is_Internal_Name (Chars (E1)) + and then Non_Internal_Name (E1) = Chars (E2)) or else (Is_Predefined_Dispatching_Operation (E1) - and then Is_Predefined_Dispatching_Operation (E2) - and then Same_TSS (E1, E2)) + and then Is_Predefined_Dispatching_Operation (E2) + and then Same_TSS (E1, E2)) or else (Is_Init_Proc (E1) and then Is_Init_Proc (E2)); end Primitive_Names_Match; @@ -15173,7 +15356,8 @@ package body Sem_Util is and then (Typ = 't' or else Ekind (Ent) = E_Package) then Error_Msg_Node_1 := Endl; - Check_SPARK_Restriction ("`END &` required", Endl, Force => True); + Check_SPARK_05_Restriction + ("`END &` required", Endl, Force => True); end if; end if; @@ -15600,12 +15784,7 @@ package body Sem_Util is -- For conditionals, we also allow loop parameters and all formals, -- including in parameters. - elsif Cond - and then - (Ekind (Ent) = E_Loop_Parameter - or else - Ekind (Ent) = E_In_Parameter) - then + elsif Cond and then Ekind_In (Ent, E_Loop_Parameter, E_In_Parameter) then null; -- For all other cases, not just unsafe, but impossible to capture @@ -15627,7 +15806,7 @@ package body Sem_Util is or else Present (Address_Clause (Ent)) or else Address_Taken (Ent) or else (Is_Library_Level_Entity (Ent) - and then Ekind (Ent) = E_Variable) + and then Ekind (Ent) = E_Variable) then return False; end if; @@ -15676,9 +15855,9 @@ package body Sem_Util is if Nkind (P) = N_If_Statement or else Nkind (P) = N_Case_Statement or else (Nkind (P) in N_Short_Circuit - and then Desc = Right_Opnd (P)) + and then Desc = Right_Opnd (P)) or else (Nkind (P) = N_If_Expression - and then Desc /= First (Expressions (P))) + and then Desc /= First (Expressions (P))) or else Nkind (P) = N_Exception_Handler or else Nkind (P) = N_Selective_Accept or else Nkind (P) = N_Conditional_Entry_Call @@ -15686,9 +15865,10 @@ package body Sem_Util is or else Nkind (P) = N_Asynchronous_Select then return False; + else Desc := P; - P := Parent (P); + P := Parent (P); -- A special Ada 2012 case: the original node may be part -- of the else_actions of a conditional expression, in which @@ -15883,6 +16063,34 @@ package body Sem_Util is end if; end Save_SPARK_Mode_And_Set; + ------------------------- + -- Scalar_Part_Present -- + ------------------------- + + function Scalar_Part_Present (T : Entity_Id) return Boolean is + C : Entity_Id; + + begin + if Is_Scalar_Type (T) then + return True; + + elsif Is_Array_Type (T) then + return Scalar_Part_Present (Component_Type (T)); + + elsif Is_Record_Type (T) or else Has_Discriminants (T) then + C := First_Component_Or_Discriminant (T); + while Present (C) loop + if Scalar_Part_Present (Etype (C)) then + return True; + else + Next_Component_Or_Discriminant (C); + end if; + end loop; + end if; + + return False; + end Scalar_Part_Present; + ------------------------ -- Scope_Is_Transient -- ------------------------ @@ -16024,9 +16232,7 @@ package body Sem_Util is procedure Set_Debug_Info_Needed_If_Not_Set (E : Entity_Id) is begin - if Present (E) - and then not Needs_Debug_Info (E) - then + if Present (E) and then not Needs_Debug_Info (E) then Set_Debug_Info_Needed (E); -- For a private type, indicate that the full view also needs @@ -16116,6 +16322,30 @@ package body Sem_Util is elsif Is_Protected_Type (T) then Set_Debug_Info_Needed_If_Not_Set (Corresponding_Record_Type (T)); + + elsif Is_Scalar_Type (T) then + + -- If the subrange bounds are materialized by dedicated constant + -- objects, also include them in the debug info to make sure the + -- debugger can properly use them. + + if Present (Scalar_Range (T)) + and then Nkind (Scalar_Range (T)) = N_Range + then + declare + Low_Bnd : constant Node_Id := Type_Low_Bound (T); + High_Bnd : constant Node_Id := Type_High_Bound (T); + + begin + if Is_Entity_Name (Low_Bnd) then + Set_Debug_Info_Needed_If_Not_Set (Entity (Low_Bnd)); + end if; + + if Is_Entity_Name (High_Bnd) then + Set_Debug_Info_Needed_If_Not_Set (Entity (High_Bnd)); + end if; + end; + end if; end if; end if; end Set_Debug_Info_Needed; @@ -16467,7 +16697,7 @@ package body Sem_Util is return No_Uint; end if; - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then if not Raises_Constraint_Error (N) then return Expr_Value (N); else @@ -16499,7 +16729,7 @@ package body Sem_Util is return No_Uint; end if; - if Is_Static_Expression (N) then + if Is_OK_Static_Expression (N) then if not Raises_Constraint_Error (N) then return Expr_Value (N); else @@ -16656,12 +16886,9 @@ package body Sem_Util is if not Is_Public (Ent) then Set_Public_Status (Ent); - if Is_Public (Ent) - and then Ekind (Ent) = E_Record_Subtype + if Is_Public (Ent) and then Ekind (Ent) = E_Record_Subtype then - then - -- The components of the propagated Itype must be public - -- as well. + -- The components of the propagated Itype must also be public declare Comp : Entity_Id; @@ -16724,7 +16951,7 @@ package body Sem_Util is or else (Is_Itype (Btyp) and then Nkind (Associated_Node_For_Itype (Btyp)) = - N_Object_Declaration + N_Object_Declaration and then Is_Return_Object (Defining_Identifier (Associated_Node_For_Itype (Btyp)))) @@ -16846,9 +17073,7 @@ package body Sem_Util is return Empty; end; - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - then + elsif Is_Private_Type (T) and then Present (Full_View (T)) then return Type_Without_Stream_Operation (Full_View (T), Op); else return Empty; @@ -17148,8 +17373,7 @@ package body Sem_Util is Elmt : Elmt_Id; begin - pragma Assert (Is_Record_Type (Typ) - and then Is_Tagged_Type (Typ)); + pragma Assert (Is_Record_Type (Typ) and then Is_Tagged_Type (Typ)); -- Collect all the parents and progenitors of Typ. If the full-view of -- private parents and progenitors is available then it is used to @@ -17249,8 +17473,7 @@ package body Sem_Util is if Is_Array_Type (Expec_Type) and then Number_Dimensions (Expec_Type) = 1 - and then - Covers (Etype (Component_Type (Expec_Type)), Found_Type) + and then Covers (Etype (Component_Type (Expec_Type)), Found_Type) then -- Use type name if available. This excludes multidimensional -- arrays and anonymous arrays. @@ -17341,7 +17564,11 @@ package body Sem_Util is -- Similarly, full and partial views may be incorrect in the instance. -- There is no simple way to insure that it is consistent ??? - elsif In_Instance then + -- A similar view discrepancy can happen in an inlined body, for the + -- same reason: inserted body may be outside of the original package + -- and only partial views are visible at the point of insertion. + + elsif In_Instance or else In_Inlined_Body then if Etype (Etype (Expr)) = Etype (Expected_Type) and then (Has_Private_Declaration (Expected_Type) @@ -17349,6 +17576,17 @@ package body Sem_Util is and then No (Parent (Expected_Type)) then return; + + elsif Nkind (Parent (Expr)) = N_Qualified_Expression + and then Entity (Subtype_Mark (Parent (Expr))) = Expected_Type + then + return; + + elsif Is_Private_Type (Expected_Type) + and then Present (Full_View (Expected_Type)) + and then Covers (Full_View (Expected_Type), Etype (Expr)) + then + return; end if; end if; @@ -17400,9 +17638,7 @@ package body Sem_Util is elsif Is_Integer_Type (Expec_Type) and then Is_RTE (Found_Type, RE_Address) - and then (Nkind (Parent (Expr)) = N_Op_Add - or else - Nkind (Parent (Expr)) = N_Op_Subtract) + and then Nkind_In (Parent (Expr), N_Op_Add, N_Op_Subtract) and then Expr = Left_Opnd (Parent (Expr)) and then Is_Integer_Type (Etype (Right_Opnd (Parent (Expr)))) then @@ -17492,10 +17728,7 @@ package body Sem_Util is Error_Msg_N ("\\found package name!", Expr); elsif Is_Entity_Name (Expr) - and then - (Ekind (Entity (Expr)) = E_Procedure - or else - Ekind (Entity (Expr)) = E_Generic_Procedure) + and then Ekind_In (Entity (Expr), E_Procedure, E_Generic_Procedure) then if Ekind (Expec_Type) = E_Access_Subprogram_Type then Error_Msg_N diff --git a/main/gcc/ada/sem_util.ads b/main/gcc/ada/sem_util.ads index 0dbd73a221a..2892916c757 100644 --- a/main/gcc/ada/sem_util.ads +++ b/main/gcc/ada/sem_util.ads @@ -88,8 +88,8 @@ package Sem_Util is function Addressable (V : Uint) return Boolean; function Addressable (V : Int) return Boolean; pragma Inline (Addressable); - -- Returns True if the value of V is the word size of an addressable - -- factor of the word size (typically 8, 16, 32 or 64). + -- Returns True if the value of V is the word size or an addressable factor + -- of the word size (typically 8, 16, 32 or 64). procedure Aggregate_Constraint_Checks (Exp : Node_Id; @@ -211,6 +211,24 @@ 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; @@ -250,14 +268,6 @@ package Sem_Util is Related_Nod : Node_Id); -- Check wrong use of dynamically tagged expression - procedure Check_Expression_Against_Static_Predicate - (Expr : Node_Id; - Typ : Entity_Id); - -- Determine whether an arbitrary expression satisfies the static predicate - -- of a type. The routine does nothing if Expr is not known at compile time - -- or Typ lacks a static predicate, otherwise it may emit a warning if the - -- expression is prohibited by the predicate. - procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id); -- Verify that the full declaration of type T has been seen. If not, place -- error message on node N. Used in object declarations, type conversions @@ -316,10 +326,6 @@ package Sem_Util is -- and post-state. Prag is a [refined] postcondition or a contract-cases -- pragma. Result_Seen is set when the pragma mentions attribute 'Result. - procedure Check_SPARK_Mode_In_Generic (N : Node_Id); - -- Given a generic package [body] or a generic subprogram [body], inspect - -- the aspect specifications (if any) and flag SPARK_Mode as illegal. - procedure Check_Unprotected_Access (Context : Node_Id; Expr : Node_Id); @@ -327,12 +333,6 @@ package Sem_Util is -- and the context is external to the protected operation, to warn against -- a possible unlocked access to data. - procedure Check_VMS (Construct : Node_Id); - -- Check that this the target is OpenVMS, and if so, return with no effect, - -- otherwise post an error noting this can only be used with OpenVMS ports. - -- The argument is the construct in question and is used to post the error - -- message. - procedure Collect_Interfaces (T : Entity_Id; Ifaces_List : out Elist_Id; @@ -452,6 +452,11 @@ package Sem_Util is -- specification. If the declaration has a defining unit name, then the -- defining entity is obtained from the defining unit name ignoring any -- child unit prefixes. + -- + -- Iterator loops also have a defining entity, which holds the list of + -- local entities declared during loop expansion. These entities need + -- debugging information, generated through QUalify_Entity_Names, and + -- the loop declaration must be placed in the table Name_Qualify_Units. function Denotes_Discriminant (N : Node_Id; @@ -571,6 +576,12 @@ package Sem_Util is -- Call is set to the node for the corresponding call. If the node N is not -- an actual parameter then Formal and Call are set to Empty. + function Find_Specific_Type (CW : Entity_Id) return Entity_Id; + -- Find specific type of a class-wide type, and handle the case of an + -- incomplete type coming either from a limited_with clause or from an + -- incomplete type declaration. If resulting type is private return its + -- full view. + function Find_Body_Discriminal (Spec_Discriminant : Entity_Id) return Entity_Id; -- Given a discriminant of the record type that implements a task or @@ -836,6 +847,13 @@ package Sem_Util is -- Return the Name component of Test_Case pragma N -- Bad name now that this no longer applies to Contract_Case ??? + function Get_Parent_Entity (Unit : Node_Id) return Entity_Id; + -- Get defining entity of parent unit of a child unit. In most cases this + -- is the defining entity of the unit, but for a child instance whose + -- parent needs a body for inlining, the instantiation node of the parent + -- has not yet been rewritten as a package declaration, and the entity has + -- to be retrieved from the Instance_Spec of the unit. + 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) @@ -887,6 +905,9 @@ package Sem_Util is -- as an access type internally, this function tests only for access types -- known to the programmer. See also Has_Tagged_Component. + function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; + -- Simple predicate to test for defaulted discriminants + type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible); -- Result of Has_Compatible_Alignment test, description found below. Note -- that the values are arranged in increasing order of problematicness. @@ -1058,6 +1079,10 @@ package Sem_Util is -- the same type. Note that Typ may not have a partial view to begin with, -- in that 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. + procedure Insert_Explicit_Dereference (N : Node_Id); -- In a context that requires a composite or subprogram type and where a -- prefix is an access type, rewrite the access type node N (which is the @@ -1165,6 +1190,15 @@ package Sem_Util is -- 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_Effectively_Volatile (Id : Entity_Id) return Boolean; + -- The SPARK property "effectively volatile" applies to both types and + -- objects. To qualify as such, an entity must be either volatile or be + -- (of) an array type subject to aspect Volatile_Components. + + function Is_Effectively_Volatile_Object (N : Node_Id) return Boolean; + -- Determine whether an arbitrary node denotes an effectively volatile + -- object. + function Is_Expression_Function (Subp : Entity_Id) return Boolean; -- Predicate to determine whether a scope entity comes from a rewritten -- expression function call, and should be inlined unconditionally. Also @@ -1203,16 +1237,6 @@ package Sem_Util is -- AI05-0139-2: Check whether Typ is one of the predefined interfaces in -- Ada.Iterator_Interfaces, or it is derived from one. - function Is_Junk_Name (N : Name_Id) return Boolean; - -- Returns True if the given name contains any of the following substrings - -- discard - -- dummy - -- ignore - -- junk - -- unused - -- Used to suppress warnings on names matching these patterns. The contents - -- of Name_Buffer and Name_Len are desteoyed by this call. - type Is_LHS_Result is (Yes, No, Unknown); function Is_LHS (N : Node_Id) return Is_LHS_Result; -- Returns Yes if N is definitely used as Name in an assignment statement. @@ -1246,7 +1270,7 @@ package Sem_Util is -- Used to test if AV is an acceptable formal for an OUT or IN OUT formal. -- Note that the Is_Variable function is not quite the right test because -- this is a case in which conversions whose expression is a variable (in - -- the Is_Variable sense) with a non-tagged type target are considered view + -- the Is_Variable sense) with an untagged type target are considered view -- conversions and hence variables. function Is_Partially_Initialized_Type @@ -1270,7 +1294,7 @@ package Sem_Util is function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean; -- Determines if type T is a potentially persistent type. A potentially - -- persistent type is defined (recursively) as a scalar type, a non-tagged + -- persistent type is defined (recursively) as a scalar type, an untagged -- record whose components are all of a potentially persistent type, or an -- array with all static constraints whose component type is potentially -- persistent. A private type is potentially persistent if the full type @@ -1306,25 +1330,16 @@ package Sem_Util is -- represent use of the N_Identifier node for a true identifier, when -- normally such nodes represent a direct name. - function Is_SPARK_Initialization_Expr (N : Node_Id) return Boolean; + function Is_SPARK_05_Initialization_Expr (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents an initialization - -- expression in SPARK, suitable for initializing an object in an object - -- declaration. + -- expression in SPARK 2005, suitable for initializing an object in an + -- object declaration. - function Is_SPARK_Object_Reference (N : Node_Id) return Boolean; + function Is_SPARK_05_Object_Reference (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents an object in SPARK - - function Is_SPARK_Volatile (Id : Entity_Id) return Boolean; - -- This routine is similar to predicate Is_Volatile, but it takes SPARK - -- semantics into account. In SPARK volatile components to not render a - -- type volatile. - - function Is_SPARK_Volatile_Object (N : Node_Id) return Boolean; - -- Determine whether an arbitrary node denotes a volatile object reference - -- according to the semantics of SPARK. To qualify as volatile, an object - -- must be subject to aspect/pragma Volatile or Atomic, or have a [sub]type - -- subject to the same attributes. Note that volatile components do not - -- render an object volatile. + -- 2005. This differs from Is_Object_Reference in that only variables, + -- constants, formal parameters, and selected_components of those are + -- valid objects in SPARK 2005. function Is_Statement (N : Node_Id) return Boolean; pragma Inline (Is_Statement); @@ -1372,16 +1387,12 @@ package Sem_Util is function Is_Variable_Size_Record (E : Entity_Id) return Boolean; -- Returns true if E has variable size components - function Is_VMS_Operator (Op : Entity_Id) return Boolean; - -- Determine whether an operator is one of the intrinsics defined - -- in the DEC system extension. - function Is_Variable (N : Node_Id; Use_Original_Node : Boolean := True) return Boolean; -- Determines if the tree referenced by N represents a variable, i.e. can -- appear on the left side of an assignment. There is one situation (formal - -- parameters) in which non-tagged type conversions are also considered + -- parameters) in which untagged type conversions are also considered -- variables, but Is_Variable returns False for such cases, since it has -- no knowledge of the context. Note that this is the point at which -- Assignment_OK is checked, and True is returned for any tree thus marked. @@ -1582,11 +1593,6 @@ package Sem_Util is -- Note that the result produced is always an expression, not a parameter -- association node, even if named notation was used. - function No_Scalar_Parts (T : Entity_Id) return Boolean; - -- Tests if type T can be determined at compile time to have no scalar - -- parts in the sense of the Valid_Scalars attribute. Returns True if - -- this is the case, meaning that the result of Valid_Scalars is True. - procedure Normalize_Actuals (N : Node_Id; S : Entity_Id; @@ -1608,17 +1614,17 @@ 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 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 + -- allowed as actuals for this function. + function Original_Corresponding_Operation (S : Entity_Id) return Entity_Id; -- [Ada 2012: AI05-0125-1]: If S is an inherited dispatching primitive S2, -- or overrides an inherited dispatching primitive S2, the original -- corresponding operation of S is the original corresponding operation of -- S2. Otherwise, it is S itself. - 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 - -- allowed as actuals for this function. - function Original_Aspect_Name (N : Node_Id) return Name_Id; -- N is a pragma node or aspect specification node. This function returns -- the name of the pragma or aspect in original source form, taking into @@ -1629,6 +1635,12 @@ package Sem_Util is -- Name_uPre, Name_uPost, Name_uInvariant, or Name_uType_Invariant being -- returned to represent the corresponding aspects with x'Class names. + function Predicate_Tests_On_Arguments (Subp : Entity_Id) return Boolean; + -- Subp is the entity for a subprogram call. This function returns True if + -- predicate tests are required for the arguments in this call (this is the + -- normal case). It returns False for special cases where these predicate + -- tests should be skipped (see body for details). + function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean; -- Returns True if the names of both entities correspond with matching -- primitives. This routine includes support for the case in which one @@ -1768,6 +1780,12 @@ package Sem_Util is -- (if any) of a package or a subprogram denoted by Context. This routine -- must be used in tandem with Restore_SPARK_Mode. + function Scalar_Part_Present (T : Entity_Id) return Boolean; + -- Tests if type T can be determined at compile time to have at least one + -- scalar part in the sense of the Valid_Scalars attribute. Returns True if + -- this is the case, and False if no scalar parts are present (meaning that + -- the result of Valid_Scalars applied to T is always vacuously True). + function Scope_Within_Or_Same (Scope1, Scope2 : Entity_Id) return Boolean; -- Determines if the entity Scope1 is the same as Scope2, or if it is -- inside it, where both entities represent scopes. Note that scopes diff --git a/main/gcc/ada/sem_vfpt.adb b/main/gcc/ada/sem_vfpt.adb deleted file mode 100644 index 5ea780a39be..00000000000 --- a/main/gcc/ada/sem_vfpt.adb +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S E M _ V F P T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with CStand; use CStand; -with Einfo; use Einfo; -with Opt; use Opt; -with Stand; use Stand; -with Targparm; use Targparm; - -package body Sem_VFpt is - - ----------------- - -- Set_D_Float -- - ----------------- - - procedure Set_D_Float (E : Entity_Id) is - VAXDF_Digits : constant := 9; - - begin - Init_Size (Base_Type (E), 64); - Init_Alignment (Base_Type (E)); - Init_Digits_Value (Base_Type (E), VAXDF_Digits); - Set_Float_Rep (Base_Type (E), VAX_Native); - Set_Float_Bounds (Base_Type (E)); - - Init_Size (E, 64); - Init_Alignment (E); - Init_Digits_Value (E, VAXDF_Digits); - Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); - end Set_D_Float; - - ----------------- - -- Set_F_Float -- - ----------------- - - procedure Set_F_Float (E : Entity_Id) is - VAXFF_Digits : constant := 6; - - begin - Init_Size (Base_Type (E), 32); - Init_Alignment (Base_Type (E)); - Init_Digits_Value (Base_Type (E), VAXFF_Digits); - Set_Float_Rep (Base_Type (E), VAX_Native); - Set_Float_Bounds (Base_Type (E)); - - Init_Size (E, 32); - Init_Alignment (E); - Init_Digits_Value (E, VAXFF_Digits); - Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); - end Set_F_Float; - - ----------------- - -- Set_G_Float -- - ----------------- - - procedure Set_G_Float (E : Entity_Id) is - VAXGF_Digits : constant := 15; - - begin - Init_Size (Base_Type (E), 64); - Init_Alignment (Base_Type (E)); - Init_Digits_Value (Base_Type (E), VAXGF_Digits); - Set_Float_Rep (Base_Type (E), VAX_Native); - Set_Float_Bounds (Base_Type (E)); - - Init_Size (E, 64); - Init_Alignment (E); - Init_Digits_Value (E, VAXGF_Digits); - Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); - end Set_G_Float; - - ------------------- - -- Set_IEEE_Long -- - ------------------- - - procedure Set_IEEE_Long (E : Entity_Id) is - IEEEL_Digits : constant := 15; - - begin - Init_Size (Base_Type (E), 64); - Init_Alignment (Base_Type (E)); - Init_Digits_Value (Base_Type (E), IEEEL_Digits); - Set_Float_Rep (Base_Type (E), IEEE_Binary); - Set_Float_Bounds (Base_Type (E)); - - Init_Size (E, 64); - Init_Alignment (E); - Init_Digits_Value (E, IEEEL_Digits); - Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); - end Set_IEEE_Long; - - -------------------- - -- Set_IEEE_Short -- - -------------------- - - procedure Set_IEEE_Short (E : Entity_Id) is - IEEES_Digits : constant := 6; - - begin - Init_Size (Base_Type (E), 32); - Init_Alignment (Base_Type (E)); - Init_Digits_Value (Base_Type (E), IEEES_Digits); - Set_Float_Rep (Base_Type (E), IEEE_Binary); - Set_Float_Bounds (Base_Type (E)); - - Init_Size (E, 32); - Init_Alignment (E); - Init_Digits_Value (E, IEEES_Digits); - Set_Scalar_Range (E, Scalar_Range (Base_Type (E))); - end Set_IEEE_Short; - - ------------------------------ - -- Set_Standard_Fpt_Formats -- - ------------------------------ - - procedure Set_Standard_Fpt_Formats is - begin - -- IEEE case - - if Opt.Float_Format = 'I' then - Set_IEEE_Short (Standard_Float); - Set_IEEE_Long (Standard_Long_Float); - Set_IEEE_Long (Standard_Long_Long_Float); - - -- Vax float case - - else - Set_F_Float (Standard_Float); - - if Opt.Float_Format_Long = 'D' then - Set_D_Float (Standard_Long_Float); - else - Set_G_Float (Standard_Long_Float); - end if; - - -- Note: Long_Long_Float gets set only in the real VMS case, - -- because this gives better results for testing out the use - -- of VAX float on non-VMS environments with the -gnatdm switch. - - if OpenVMS_On_Target then - Set_G_Float (Standard_Long_Long_Float); - end if; - end if; - end Set_Standard_Fpt_Formats; - -end Sem_VFpt; diff --git a/main/gcc/ada/sem_vfpt.ads b/main/gcc/ada/sem_vfpt.ads deleted file mode 100644 index b6c9465ac9c..00000000000 --- a/main/gcc/ada/sem_vfpt.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S E M _ V F P T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2007, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains specialized routines for handling the Alpha --- floating point formats. It is used only in Alpha implementations. --- Note that this means that the caller can assume that we are on an --- Alpha implementation, and that Vax floating-point formats are valid. - -with Types; use Types; - -package Sem_VFpt is - - procedure Set_D_Float (E : Entity_Id); - -- Sets the given floating-point entity to have Vax D_Float format - - procedure Set_F_Float (E : Entity_Id); - -- Sets the given floating-point entity to have Vax F_Float format - - procedure Set_G_Float (E : Entity_Id); - -- Sets the given floating-point entity to have Vax G_Float format - - procedure Set_IEEE_Short (E : Entity_Id); - -- Sets the given floating-point entity to have IEEE Short format - - procedure Set_IEEE_Long (E : Entity_Id); - -- Sets the given floating-point entity to have IEEE Long format - - procedure Set_Standard_Fpt_Formats; - -- This procedure sets the appropriate formats for the standard - -- floating-point types in Standard, based on the setting of - -- the flags Opt.Float_Format and Opt.Float_Format_Long - -end Sem_VFpt; diff --git a/main/gcc/ada/sem_warn.adb b/main/gcc/ada/sem_warn.adb index 8b47332be7e..7bdda640731 100644 --- a/main/gcc/ada/sem_warn.adb +++ b/main/gcc/ada/sem_warn.adb @@ -820,9 +820,9 @@ package body Sem_Warn is raise Program_Error; end Body_Formal; - ----------------------------------- - -- May_Need_Initialized_Actual -- - ----------------------------------- + --------------------------------- + -- May_Need_Initialized_Actual -- + --------------------------------- procedure May_Need_Initialized_Actual (Ent : Entity_Id) is T : constant Entity_Id := Etype (Ent); @@ -1060,7 +1060,8 @@ package body Sem_Warn is -- We are only interested in source entities. We also don't issue -- warnings within instances, since the proper place for such - -- warnings is on the template when it is compiled. + -- warnings is on the template when it is compiled, and we don't + -- issue warnings for variables with names like Junk, Discard etc. if Comes_From_Source (E1) and then Instantiation_Location (Sloc (E1)) = No_Location @@ -1109,11 +1110,15 @@ package body Sem_Warn is -- since a given instance could have modifications outside -- the package. + -- Note that we used to check Address_Taken here, but we don't + -- want to do that since it can be set for non-source cases, + -- e.g. the Unrestricted_Access from a valid attribute, and + -- the wanted effect is included in Never_Set_In_Source. + elsif Warn_On_Constant and then (Ekind (E1) = E_Variable and then Has_Initial_Value (E1)) and then Never_Set_In_Source_Check_Spec (E1) - and then not Address_Taken (E1) and then not Generic_Package_Spec_Entity (E1) then -- A special case, if this variable is volatile and not @@ -1145,7 +1150,9 @@ package body Sem_Warn is and then not Has_Pragma_Unreferenced_Check_Spec (E1) and then not Has_Pragma_Unmodified_Check_Spec (E1) then - if not Warnings_Off_E1 then + if not Warnings_Off_E1 + and then not Has_Junk_Name (E1) + then Error_Msg_N -- CODEFIX ("?k?& is not modified, " & "could be declared constant!", @@ -1267,7 +1274,11 @@ package body Sem_Warn is -- the formal is not modified. else - In_Out_Warnings.Append (E1); + -- Suppress the warnings for a junk name + + if not Has_Junk_Name (E1) then + In_Out_Warnings.Append (E1); + end if; end if; -- Other cases of formals @@ -1277,6 +1288,7 @@ package body Sem_Warn is if Referenced_Check_Spec (E1) then if not Has_Pragma_Unmodified_Check_Spec (E1) and then not Warnings_Off_E1 + and then not Has_Junk_Name (E1) then Output_Reference_Error ("?f?formal parameter& is read but " @@ -1285,6 +1297,7 @@ package body Sem_Warn is elsif not Has_Pragma_Unreferenced_Check_Spec (E1) and then not Warnings_Off_E1 + and then not Has_Junk_Name (E1) then Output_Reference_Error ("?f?formal parameter& is not referenced!"); @@ -1297,7 +1310,7 @@ package body Sem_Warn is if Referenced (E1) then if not Has_Unmodified (E1) and then not Warnings_Off_E1 - and then not Is_Junk_Name (Chars (E1)) + and then not Has_Junk_Name (E1) then Output_Reference_Error ("?v?variable& is read but never assigned!"); @@ -1306,7 +1319,7 @@ package body Sem_Warn is elsif not Has_Unreferenced (E1) and then not Warnings_Off_E1 - and then not Is_Junk_Name (Chars (E1)) + and then not Has_Junk_Name (E1) then Output_Reference_Error -- CODEFIX ("?v?variable& is never read and never assigned!"); @@ -1373,7 +1386,9 @@ package body Sem_Warn is if Nkind (UR) = N_Simple_Return_Statement and then not Has_Pragma_Unmodified_Check_Spec (E1) then - if not Warnings_Off_E1 then + if not Warnings_Off_E1 + and then not Has_Junk_Name (E1) + then Error_Msg_NE ("?v?OUT parameter& not set before return", UR, E1); @@ -1593,7 +1608,9 @@ package body Sem_Warn is (E1, Body_Formal (E1, Accept_Statement => Anod)); end if; - elsif not Warnings_Off_E1 then + elsif not Warnings_Off_E1 + and then not Has_Junk_Name (E1) + then Unreferenced_Entities.Append (E1); end if; end if; @@ -1609,7 +1626,7 @@ package body Sem_Warn is and then Instantiation_Depth (Sloc (E1)) = 0 and then Warn_On_Redundant_Constructs then - if not Warnings_Off_E1 then + if not Warnings_Off_E1 and then not Has_Junk_Name (E1) then Unreferenced_Entities.Append (E1); -- Force warning on entity @@ -1755,6 +1772,7 @@ package body Sem_Warn is (Sloc (N), Sloc (Unset_Reference (E)))) and then not Has_Pragma_Unmodified_Check_Spec (E) and then not Warnings_Off_Check_Spec (E) + and then not Has_Junk_Name (E) then -- We may have an unset reference. The first test is whether -- this is an access to a discriminant of a record or a @@ -2660,6 +2678,44 @@ package body Sem_Warn is end if; end Goto_Spec_Entity; + ------------------- + -- Has_Junk_Name -- + ------------------- + + function Has_Junk_Name (E : Entity_Id) return Boolean is + function Match (S : String) return Boolean; + -- Return true if substring S is found in Name_Buffer (1 .. Name_Len) + + ----------- + -- Match -- + ----------- + + function Match (S : String) return Boolean is + Slen1 : constant Integer := S'Length - 1; + + begin + for J in 1 .. Name_Len - S'Length + 1 loop + if Name_Buffer (J .. J + Slen1) = S then + return True; + end if; + end loop; + + return False; + end Match; + + -- Start of processing for Has_Junk_Name + + begin + Get_Unqualified_Decoded_Name_String (Chars (E)); + + return + Match ("discard") or else + Match ("dummy") or else + Match ("ignore") or else + Match ("junk") or else + Match ("unused"); + end Has_Junk_Name; + -------------------------------------- -- Has_Pragma_Unmodified_Check_Spec -- -------------------------------------- @@ -3594,11 +3650,7 @@ package body Sem_Warn is if Is_Array_Type (Typ) and then not Is_Constrained (Typ) and then Number_Dimensions (Typ) = 1 - and then (Root_Type (Typ) = Standard_String - or else - Root_Type (Typ) = Standard_Wide_String - or else - Root_Type (Typ) = Standard_Wide_Wide_String) + and then Is_Standard_String_Type (Typ) and then not Has_Warnings_Off (Typ) then LB := Type_Low_Bound (Etype (First_Index (Typ))); @@ -3910,7 +3962,7 @@ package body Sem_Warn is if not Referenced_Check_Spec (E) and then not Has_Pragma_Unreferenced_Check_Spec (E) and then not Warnings_Off_Check_Spec (E) - and then not Is_Junk_Name (Chars (Spec_E)) + and then not Has_Junk_Name (Spec_E) then case Ekind (E) is when E_Variable => @@ -3963,14 +4015,16 @@ package body Sem_Warn is end if; when E_Constant => - if Present (Renamed_Object (E)) - and then Comes_From_Source (Renamed_Object (E)) - then - Error_Msg_N -- CODEFIX - ("?u?renamed constant & is not referenced!", E); - else - Error_Msg_N -- CODEFIX - ("?u?constant & is not referenced!", E); + if not Has_Pragma_Unreferenced_Objects (Etype (E)) then + if Present (Renamed_Object (E)) + and then Comes_From_Source (Renamed_Object (E)) + then + Error_Msg_N -- CODEFIX + ("?u?renamed constant & is not referenced!", E); + else + Error_Msg_N -- CODEFIX + ("?u?constant & is not referenced!", E); + end if; end if; when E_In_Parameter | @@ -4115,7 +4169,7 @@ package body Sem_Warn is and then not Is_Exported (Ent) and then Safe_To_Capture_Value (N, Ent) and then not Has_Pragma_Unreferenced_Check_Spec (Ent) - and then not Is_Junk_Name (Chars (Ent)) + and then not Has_Junk_Name (Ent) then -- Before we issue the message, check covering exception handlers. -- Search up tree for enclosing statement sequences and handlers. diff --git a/main/gcc/ada/sem_warn.ads b/main/gcc/ada/sem_warn.ads index efd31950518..41c5a22e3e9 100644 --- a/main/gcc/ada/sem_warn.ads +++ b/main/gcc/ada/sem_warn.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,4 +239,18 @@ package Sem_Warn is -- block or subprogram to see if there are any variables for which useless -- assignments were made (assignments whose values were never read). + ---------------------- + -- Utility Routines -- + ---------------------- + + function Has_Junk_Name (E : Entity_Id) return Boolean; + -- Return True if the entity name contains any of the following substrings: + -- discard + -- dummy + -- ignore + -- junk + -- unused + -- Used to suppress warnings on names matching these patterns. The contents + -- of Name_Buffer and Name_Len are destroyed by this call. + end Sem_Warn; diff --git a/main/gcc/ada/set_targ.adb b/main/gcc/ada/set_targ.adb index d6268c82333..46f40cc047d 100755 --- a/main/gcc/ada/set_targ.adb +++ b/main/gcc/ada/set_targ.adb @@ -130,6 +130,10 @@ package body Set_Targ is -- Local Subprograms -- ----------------------- + procedure Read_Target_Dependent_Values (File_Name : String); + -- Read target dependent values from File_Name, and set the target + -- dependent values (global variables) declared in this package. + procedure Fail (E : String); pragma No_Return (Fail); -- Terminate program with fatal error message passed as parameter @@ -221,26 +225,8 @@ package body Set_Targ is Write_Str ("pragma Float_Representation ("); case Float_Rep is - when IEEE_Binary => - Write_Str ("IEEE"); - - when VAX_Native => - case Digs is - when 6 => - Write_Str ("VAXF"); - - when 9 => - Write_Str ("VAXD"); - - when 15 => - Write_Str ("VAXG"); - - when others => - Write_Str ("VAX_"); - Write_Int (Int (Digs)); - end case; - - when AAMP => Write_Str ("AAMP"); + when IEEE_Binary => Write_Str ("IEEE"); + when AAMP => Write_Str ("AAMP"); end case; Write_Line (", " & T (1 .. Last) & ");"); @@ -455,8 +441,6 @@ package body Set_Targ is case E.FLOAT_REP is when IEEE_Binary => AddC ('I'); - when VAX_Native => - AddC ('V'); when AAMP => AddC ('A'); end case; @@ -481,6 +465,258 @@ package body Set_Targ is end if; end Write_Target_Dependent_Values; + ---------------------------------- + -- Read_Target_Dependent_Values -- + ---------------------------------- + + procedure Read_Target_Dependent_Values (File_Name : String) is + File_Desc : File_Descriptor; + N : Natural; + + type ANat is access all Natural; + -- Pointer to Nat or Pos value (it is harmless to treat Pos values + -- as Nat via Unchecked_Conversion). + + function To_ANat is new Unchecked_Conversion (Address, ANat); + + VP : ANat; + + Buffer : String (1 .. 2000); + Buflen : Natural; + -- File information and length (2000 easily enough) + + Nam_Buf : String (1 .. 40); + Nam_Len : Natural; + + procedure Check_Spaces; + -- Checks that we have one or more spaces and skips them + + procedure FailN (S : String); + -- Calls Fail adding " name in file xxx", where name is the currently + -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the + -- name of the file. + + procedure Get_Name; + -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls + -- Skip_Spaces to skip any following spaces. Note that the name is + -- terminated by a sequence of at least two spaces. + + function Get_Nat return Natural; + -- N on entry points to decimal integer, scan out decimal integer + -- and return it, leaving N pointing to following space or LF. + + procedure Skip_Spaces; + -- Skip past spaces + + ------------------ + -- Check_Spaces -- + ------------------ + + procedure Check_Spaces is + begin + if N > Buflen or else Buffer (N) /= ' ' then + FailN ("missing space for"); + end if; + + Skip_Spaces; + return; + end Check_Spaces; + + ----------- + -- FailN -- + ----------- + + procedure FailN (S : String) is + begin + Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " + & File_Name); + end FailN; + + -------------- + -- Get_Name -- + -------------- + + procedure Get_Name is + begin + Nam_Len := 0; + + -- Scan out name and put it in Nam_Buf + + loop + if N > Buflen or else Buffer (N) = ASCII.LF then + FailN ("incorrectly formatted line for"); + end if; + + -- Name is terminated by two blanks + + exit when N < Buflen and then Buffer (N .. N + 1) = " "; + + Nam_Len := Nam_Len + 1; + + if Nam_Len > Nam_Buf'Last then + Fail ("name too long"); + end if; + + Nam_Buf (Nam_Len) := Buffer (N); + N := N + 1; + end loop; + + Check_Spaces; + end Get_Name; + + ------------- + -- Get_Nat -- + ------------- + + function Get_Nat return Natural is + Result : Natural := 0; + + begin + loop + if N > Buflen + or else Buffer (N) not in '0' .. '9' + or else Result > 999 + then + FailN ("bad value for"); + end if; + + Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); + N := N + 1; + + exit when N <= Buflen + and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); + end loop; + + return Result; + end Get_Nat; + + ----------------- + -- Skip_Spaces -- + ----------------- + + procedure Skip_Spaces is + begin + while N <= Buflen and Buffer (N) = ' ' loop + N := N + 1; + end loop; + end Skip_Spaces; + + -- Start of processing for Read_Target_Dependent_Values + + begin + File_Desc := Open_Read (File_Name, Text); + + if File_Desc = Invalid_FD then + Fail ("cannot read file " & File_Name); + end if; + + Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); + + if Buflen = Buffer'Length then + Fail ("file is too long: " & File_Name); + end if; + + -- Scan through file for properly formatted entries in first section + + N := 1; + while N <= Buflen and then Buffer (N) /= ASCII.LF loop + Get_Name; + + -- Validate name and get corresponding value pointer + + VP := null; + + for J in DTN'Range loop + if DTN (J).all = Nam_Buf (1 .. Nam_Len) then + VP := To_ANat (DTV (J)); + DTR (J) := True; + exit; + end if; + end loop; + + if VP = null then + FailN ("unrecognized name"); + end if; + + -- Scan out value + + VP.all := Get_Nat; + + if N > Buflen or else Buffer (N) /= ASCII.LF then + FailN ("misformatted line for"); + end if; + + N := N + 1; -- skip LF + end loop; + + -- Fall through this loop when all lines in first section read. + -- Check that values have been supplied for all entries. + + for J in DTR'Range loop + if not DTR (J) then + Fail ("missing entry for " & DTN (J).all & " in file " + & File_Name); + end if; + end loop; + + -- Now acquire FPT entries + + if N >= Buflen then + Fail ("missing entries for FPT modes in file " & File_Name); + end if; + + if Buffer (N) = ASCII.LF then + N := N + 1; + else + Fail ("missing blank line in file " & File_Name); + end if; + + Num_FPT_Modes := 0; + while N <= Buflen loop + Get_Name; + + Num_FPT_Modes := Num_FPT_Modes + 1; + + declare + E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); + + begin + E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); + + E.DIGS := Get_Nat; + Check_Spaces; + + 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; + + N := N + 1; + Check_Spaces; + + E.PRECISION := Get_Nat; + Check_Spaces; + + E.ALIGNMENT := Get_Nat; + + if Buffer (N) /= ASCII.LF then + FailN ("junk at end of line for"); + end if; + + -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values + + E.SIZE := + (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT; + + N := N + 1; + end; + end loop; + end Read_Target_Dependent_Values; + -- Package Initialization, set target dependent values. This must be done -- early on, before we start accessing various compiler packages, since -- these values are used all over the place. @@ -565,40 +801,6 @@ begin end loop; end; - -- If the switch is not set, we get all values from the back end - - if Opt.Target_Dependent_Info_Read_Name = null then - - -- Set values by direct calls to the back end - - Bits_BE := Get_Bits_BE; - Bits_Per_Unit := Get_Bits_Per_Unit; - Bits_Per_Word := Get_Bits_Per_Word; - Bytes_BE := Get_Bytes_BE; - Char_Size := Get_Char_Size; - Double_Float_Alignment := Get_Double_Float_Alignment; - Double_Scalar_Alignment := Get_Double_Scalar_Alignment; - Double_Size := Get_Double_Size; - Float_Size := Get_Float_Size; - Float_Words_BE := Get_Float_Words_BE; - Int_Size := Get_Int_Size; - Long_Double_Size := Get_Long_Double_Size; - Long_Long_Size := Get_Long_Long_Size; - Long_Size := Get_Long_Size; - Maximum_Alignment := Get_Maximum_Alignment; - Max_Unaligned_Field := Get_Max_Unaligned_Field; - Pointer_Size := Get_Pointer_Size; - Short_Enums := Get_Short_Enums; - Short_Size := Get_Short_Size; - Strict_Alignment := Get_Strict_Alignment; - System_Allocator_Alignment := Get_System_Allocator_Alignment; - Wchar_T_Size := Get_Wchar_T_Size; - Words_BE := Get_Words_BE; - - -- Register floating-point types from the back end - - Register_Back_End_Types (Register_Float_Type'Access); - -- Case of reading the target dependent values from file -- This is bit more complex than might be expected, because it has to be @@ -607,257 +809,50 @@ begin -- etc to read the file. We do this at the System.OS_Lib level since it is -- too early to be using Osint directly. + if Opt.Target_Dependent_Info_Read_Name /= null then + Read_Target_Dependent_Values (Target_Dependent_Info_Read_Name.all); else - Read_Target_Dependent_Values : declare - File_Desc : File_Descriptor; - N : Natural; - - type ANat is access all Natural; - -- Pointer to Nat or Pos value (it is harmless to treat Pos values - -- as Nat via Unchecked_Conversion). - - function To_ANat is new Unchecked_Conversion (Address, ANat); - - VP : ANat; - - Buffer : String (1 .. 2000); - Buflen : Natural; - -- File information and length (2000 easily enough) - - Nam_Buf : String (1 .. 40); - Nam_Len : Natural; - - procedure Check_Spaces; - -- Checks that we have one or more spaces and skips them - - procedure FailN (S : String); - -- Calls Fail adding " name in file xxx", where name is the currently - -- gathered name in Nam_Buf, surrounded by quotes, and xxx is the - -- name of the file. - - procedure Get_Name; - -- Scan out name, leaving it in Nam_Buf with Nam_Len set. Calls - -- Skip_Spaces to skip any following spaces. Note that the name is - -- terminated by a sequence of at least two spaces. - - function Get_Nat return Natural; - -- N on entry points to decimal integer, scan out decimal integer - -- and return it, leaving N pointing to following space or LF. - - procedure Skip_Spaces; - -- Skip past spaces - - ------------------ - -- Check_Spaces -- - ------------------ - - procedure Check_Spaces is - begin - if N > Buflen or else Buffer (N) /= ' ' then - FailN ("missing space for"); - end if; - - Skip_Spaces; - return; - end Check_Spaces; - - ----------- - -- FailN -- - ----------- - - procedure FailN (S : String) is - begin - Fail (S & " """ & Nam_Buf (1 .. Nam_Len) & """ in file " - & Target_Dependent_Info_Read_Name.all); - end FailN; - - -------------- - -- Get_Name -- - -------------- - - procedure Get_Name is - begin - Nam_Len := 0; - - -- Scan out name and put it in Nam_Buf - - loop - if N > Buflen or else Buffer (N) = ASCII.LF then - FailN ("incorrectly formatted line for"); - end if; - - -- Name is terminated by two blanks - - exit when N < Buflen and then Buffer (N .. N + 1) = " "; - - Nam_Len := Nam_Len + 1; - - if Nam_Len > Nam_Buf'Last then - Fail ("name too long"); - end if; - - Nam_Buf (Nam_Len) := Buffer (N); - N := N + 1; - end loop; - - Check_Spaces; - end Get_Name; - - ------------- - -- Get_Nat -- - ------------- - - function Get_Nat return Natural is - Result : Natural := 0; - - begin - loop - if N > Buflen - or else Buffer (N) not in '0' .. '9' - or else Result > 999 - then - FailN ("bad value for"); - end if; - - Result := Result * 10 + (Character'Pos (Buffer (N)) - 48); - N := N + 1; - - exit when N <= Buflen - and then (Buffer (N) = ASCII.LF or else Buffer (N) = ' '); - end loop; - - return Result; - end Get_Nat; - - ----------------- - -- Skip_Spaces -- - ----------------- - - procedure Skip_Spaces is - begin - while N <= Buflen and Buffer (N) = ' ' loop - N := N + 1; - end loop; - end Skip_Spaces; - - -- Start of processing for Read_Target_Dependent_Values + -- If the back-end comes with a target config file, then use it + -- to set the values + declare + Back_End_Config_File : constant String_Ptr := + Get_Back_End_Config_File; begin - File_Desc := Open_Read (Target_Dependent_Info_Read_Name.all, Text); - - if File_Desc = Invalid_FD then - Fail ("cannot read file " & Target_Dependent_Info_Read_Name.all); - end if; + if Back_End_Config_File /= null then + Read_Target_Dependent_Values (Back_End_Config_File.all); - Buflen := Read (File_Desc, Buffer'Address, Buffer'Length); + -- Otherwise we get all values from the back end directly - if Buflen = Buffer'Length then - Fail ("file is too long: " & Target_Dependent_Info_Read_Name.all); - end if; - - -- Scan through file for properly formatted entries in first section - - N := 1; - while N <= Buflen and then Buffer (N) /= ASCII.LF loop - Get_Name; - - -- Validate name and get corresponding value pointer - - VP := null; - - for J in DTN'Range loop - if DTN (J).all = Nam_Buf (1 .. Nam_Len) then - VP := To_ANat (DTV (J)); - DTR (J) := True; - exit; - end if; - end loop; - - if VP = null then - FailN ("unrecognized name"); - end if; - - -- Scan out value - - VP.all := Get_Nat; - - if N > Buflen or else Buffer (N) /= ASCII.LF then - FailN ("misformatted line for"); - end if; - - N := N + 1; -- skip LF - end loop; - - -- Fall through this loop when all lines in first section read. - -- Check that values have been supplied for all entries. - - for J in DTR'Range loop - if not DTR (J) then - Fail ("missing entry for " & DTN (J).all & " in file " - & Target_Dependent_Info_Read_Name.all); - end if; - end loop; - - -- Now acquire FPT entries - - if N >= Buflen then - Fail ("missing entries for FPT modes in file " - & Target_Dependent_Info_Read_Name.all); - end if; - - if Buffer (N) = ASCII.LF then - N := N + 1; else - Fail ("missing blank line in file " - & Target_Dependent_Info_Read_Name.all); + Bits_BE := Get_Bits_BE; + Bits_Per_Unit := Get_Bits_Per_Unit; + Bits_Per_Word := Get_Bits_Per_Word; + Bytes_BE := Get_Bytes_BE; + Char_Size := Get_Char_Size; + Double_Float_Alignment := Get_Double_Float_Alignment; + Double_Scalar_Alignment := Get_Double_Scalar_Alignment; + Double_Size := Get_Double_Size; + Float_Size := Get_Float_Size; + Float_Words_BE := Get_Float_Words_BE; + Int_Size := Get_Int_Size; + Long_Double_Size := Get_Long_Double_Size; + Long_Long_Size := Get_Long_Long_Size; + Long_Size := Get_Long_Size; + Maximum_Alignment := Get_Maximum_Alignment; + Max_Unaligned_Field := Get_Max_Unaligned_Field; + Pointer_Size := Get_Pointer_Size; + Short_Enums := Get_Short_Enums; + Short_Size := Get_Short_Size; + Strict_Alignment := Get_Strict_Alignment; + System_Allocator_Alignment := Get_System_Allocator_Alignment; + Wchar_T_Size := Get_Wchar_T_Size; + Words_BE := Get_Words_BE; + + -- Register floating-point types from the back end + + Register_Back_End_Types (Register_Float_Type'Access); end if; - - Num_FPT_Modes := 0; - while N <= Buflen loop - Get_Name; - - Num_FPT_Modes := Num_FPT_Modes + 1; - - declare - E : FPT_Mode_Entry renames FPT_Mode_Table (Num_FPT_Modes); - - begin - E.NAME := new String'(Nam_Buf (1 .. Nam_Len)); - - E.DIGS := Get_Nat; - Check_Spaces; - - case Buffer (N) is - when 'I' => - E.FLOAT_REP := IEEE_Binary; - when 'V' => - E.FLOAT_REP := VAX_Native; - when 'A' => - E.FLOAT_REP := AAMP; - when others => - FailN ("bad float rep field for"); - end case; - - N := N + 1; - Check_Spaces; - - E.PRECISION := Get_Nat; - Check_Spaces; - - E.ALIGNMENT := Get_Nat; - - if Buffer (N) /= ASCII.LF then - FailN ("junk at end of line for"); - end if; - - -- ??? We do not read E.SIZE, see Write_Target_Dependent_Values - - E.SIZE := - (E.PRECISION + E.ALIGNMENT - 1) / E.ALIGNMENT * E.ALIGNMENT; - - N := N + 1; - end; - end loop; - end Read_Target_Dependent_Values; + end; end if; end Set_Targ; diff --git a/main/gcc/ada/sigtramp-armvxw.c b/main/gcc/ada/sigtramp-armvxw.c deleted file mode 100644 index cbe774ff607..00000000000 --- a/main/gcc/ada/sigtramp-armvxw.c +++ /dev/null @@ -1,250 +0,0 @@ -/**************************************************************************** - * * - * GNAT COMPILER COMPONENTS * - * * - * S I G T R A M P * - * * - * Asm Implementation File * - * * - * Copyright (C) 2014, Free Software Foundation, Inc. * - * * - * GNAT is 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. * - * * - ****************************************************************************/ - -/****************************************************** - * ARM-VxWorks version of the __gnat_sigtramp service * - ******************************************************/ - -#include "sigtramp.h" -/* See sigtramp.h for a general explanation of functionality. */ - -#include -#include -#include - -/* ---------------------- - -- 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 - 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 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. */ - -/* ----------------------------------------- - -- Protypes for our internal asm stubs -- - ----------------------------------------- - - SC_PREGS is always expected to be SIGCONTEXT->sc_pregs. 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_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 (int signo, void *si, void *sc, - __sigtramphandler_t * handler) - __attribute__((optimize(2))); - -void __gnat_sigtramp (int signo, void *si, void *sc, - __sigtramphandler_t * handler) -{ - struct sigcontext * sctx = (struct sigcontext *) sc; - - __gnat_sigtramp_common (signo, si, sctx, handler, sctx->sc_pregs); -} - - -/* --------------------------- - -- And now the asm stubs -- - --------------------------- - - They all have a common structure with blocks of asm sequences queued one - after the others. Typically: - - SYMBOL_START - - CFI_DIRECTIVES - CFI_DEF_CFA, - CFI_COMMON_REGISTERS, - ... - - STUB_BODY - asm code to establish frame, setup the cfa reg value, - call the real signal handler, ... - - SYMBOL_END -*/ - -/*-------------------------------- - -- Misc constants and helpers -- - -------------------------------- */ - -/* REGNO constants, dwarf column numbers for registers of interest. */ - -#define REGNO_G_REG_OFFSET(N) (N) - -#define REGNO_PC_OFFSET 15 /* PC_REGNUM */ - -/* asm string construction helpers. */ - -#define STR(TEXT) #TEXT -/* stringify expanded TEXT, surrounding it with double quotes. */ - -#define S(E) STR(E) -/* stringify E, which will resolve as text but may contain macros - still to be expanded. */ - -/* asm (TEXT) outputs TEXT. These facilitate the output of - multine contents: */ -#define TAB(S) "\t" S -#define CR(S) S "\n" - -#undef TCR -#define TCR(S) TAB(CR(S)) - -/*------------------------------ - -- Stub construction blocks -- - ------------------------------ */ - -/* CFA setup block - --------------- - Only non-volatile registers are suitable for a CFA base. These are the - only ones we can expect to be able retrieve from the unwinding context - while walking up the chain, saved by at least the bottom-most exception - propagation services. We use r8 here and set it to the value we need - in stub body that follows. Any of r4-r8 should work. */ - -#define CFA_REG 8 - -#define CFI_DEF_CFA \ -CR(".cfi_def_cfa " S(CFA_REG) ", 0") - -/* Register location blocks - ------------------------ - Rules to find registers of interest from the CFA. This should comprise - all the non-volatile registers relevant to the interrupted context. */ - -#define COMMON_CFI(REG) \ - ".cfi_offset " S(REGNO_##REG) "," S(REG_SET_##REG) - -#define CFI_COMMON_REGS \ -CR("# CFI for common registers\n") \ -TCR(COMMON_CFI(G_REG_OFFSET(0))) \ -TCR(COMMON_CFI(G_REG_OFFSET(1))) \ -TCR(COMMON_CFI(G_REG_OFFSET(2))) \ -TCR(COMMON_CFI(G_REG_OFFSET(3))) \ -TCR(COMMON_CFI(G_REG_OFFSET(4))) \ -TCR(COMMON_CFI(G_REG_OFFSET(5))) \ -TCR(COMMON_CFI(G_REG_OFFSET(6))) \ -TCR(COMMON_CFI(G_REG_OFFSET(7))) \ -TCR(COMMON_CFI(G_REG_OFFSET(8))) \ -TCR(COMMON_CFI(G_REG_OFFSET(9))) \ -TCR(COMMON_CFI(G_REG_OFFSET(10))) \ -TCR(COMMON_CFI(G_REG_OFFSET(11))) \ -TCR(COMMON_CFI(G_REG_OFFSET(12))) \ -TCR(COMMON_CFI(G_REG_OFFSET(13))) \ -TCR(COMMON_CFI(G_REG_OFFSET(14))) \ -TCR(COMMON_CFI(PC_OFFSET)) \ -TCR(".cfi_return_column " S(REGNO_PC_OFFSET)) - -/* Trampoline body block - --------------------- */ - -#define SIGTRAMP_BODY \ -CR("") \ -TCR("# Allocate frame and save the non-volatile") \ -TCR("# registers we're going to modify") \ -TCR("mov ip, sp") \ -TCR("stmfd sp!, {r"S(CFA_REG)", fp, ip, lr, pc}") \ -TCR("# Setup CFA_REG = sc_pregs, that we'll retrieve as our CFA value") \ -TCR("ldr r"S(CFA_REG)", [ip]") \ -TCR("") \ -TCR("# Call the real handler. The signo, siginfo and sigcontext") \ -TCR("# arguments are the same as those we received in r0, r1 and r2") \ -TCR("sub fp, ip, #4") \ -TCR("blx r3") \ -TCR("# Restore our callee-saved items, release our frame and return") \ -TCR("ldmfd sp, {r"S(CFA_REG)", fp, sp, pc}") - - -/* Symbol definition block - ----------------------- */ - -#define SIGTRAMP_START(SYM) \ -CR("# " S(SYM) " cfi trampoline") \ -TCR(".type " S(SYM) ", %function") \ -CR("") \ -CR(S(SYM) ":") \ -TCR(".cfi_startproc") \ -TCR(".cfi_signal_frame") - -/* Symbol termination block - ------------------------ */ - -#define SIGTRAMP_END(SYM) \ -CR(".cfi_endproc") \ -TCR(".size " S(SYM) ", .-" S(SYM)) - -/*---------------------------- - -- And now, the real code -- - ---------------------------- */ - -/* Text section start. The compiler isn't aware of that switch. */ - -asm (".text\n" - TCR(".align 2")); - -/* 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/main/gcc/ada/sigtramp-ppcvxw.c b/main/gcc/ada/sigtramp-vxworks.c similarity index 67% rename from main/gcc/ada/sigtramp-ppcvxw.c rename to main/gcc/ada/sigtramp-vxworks.c index ff2f0a8792b..2119296dc1d 100644 --- a/main/gcc/ada/sigtramp-ppcvxw.c +++ b/main/gcc/ada/sigtramp-vxworks.c @@ -19,26 +19,44 @@ * 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 * - * . * + * 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. * * * ****************************************************************************/ -/********************************************************** - * PowerPC-VxWorks version of the __gnat_sigtramp service * - **********************************************************/ +/************************************************** + * VxWorks version of the __gnat_sigtramp service * + **************************************************/ #include "sigtramp.h" /* See sigtramp.h for a general explanation of functionality. */ #include #include +#ifndef __RTP__ #include +#else +#include +#include + +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 -- @@ -47,29 +65,29 @@ 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 - and state where to find the registers as offsets from there. + (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 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. + 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. */ -/* ----------------------------------------- - -- Protypes for our internal asm stubs -- - ----------------------------------------- +/* ------------------------------------------- + -- Prototypes for our internal asm stubs -- + ------------------------------------------- - SC_PREGS is always expected to be SIGCONTEXT->sc_pregs. Eventhough our - symbols will remain local, the prototype claims "extern" and not - "static" to prevent compiler complaints about a symbol used but never - defined. */ + 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. */ @@ -91,9 +109,17 @@ void __gnat_sigtramp (int signo, void *si, void *sc, void __gnat_sigtramp (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_common (signo, si, mcontext, handler, mcontext); +#else struct sigcontext * sctx = (struct sigcontext *) sc; __gnat_sigtramp_common (signo, si, sctx, handler, sctx->sc_pregs); +#endif } @@ -122,16 +148,6 @@ void __gnat_sigtramp (int signo, void *si, void *sc, -- Misc constants and helpers -- -------------------------------- */ -/* REGNO constants, dwarf column numbers for registers of interest. */ - -#define REGNO_LR 65 -#define REGNO_CTR 66 -#define REGNO_CR 70 -#define REGNO_XER 76 -#define REGNO_GR(N) (N) - -#define REGNO_PC 67 /* ARG_POINTER_REGNUM */ - /* asm string construction helpers. */ #define STR(TEXT) #TEXT @@ -149,6 +165,33 @@ void __gnat_sigtramp (int signo, void *si, void *sc, #undef TCR #define TCR(S) TAB(CR(S)) +/* REGNO constants, dwarf column numbers for registers of interest. */ + +#if defined (__PPC__) + +#define REGNO_LR 65 +#define REGNO_CTR 66 +#define REGNO_CR 70 +#define REGNO_XER 76 +#define REGNO_GR(N) (N) + +#define REGNO_PC 67 /* ARG_POINTER_REGNUM */ + +#define FUNCTION "@function" + +#elif defined (__ARMEL__) + +#define REGNO_G_REG_OFFSET(N) (N) + +#define REGNO_PC_OFFSET 15 /* PC_REGNUM */ + +#define FUNCTION "%function" + +#else +Not_implemented; +#endif /* REGNO constants */ + + /*------------------------------ -- Stub construction blocks -- ------------------------------ */ @@ -158,13 +201,27 @@ void __gnat_sigtramp (int signo, void *si, void *sc, Only non-volatile registers are suitable for a CFA base. These are the only ones we can expect to be able retrieve from the unwinding context while walking up the chain, saved by at least the bottom-most exception - propagation services. We use r15 here and set it to the value we need - in stub body that follows. Note that r14 is inappropriate here, even - though it is non-volatile according to the ABI, because GCC uses it as - an extra SCRATCH on SPE targets. */ + propagation services. We set a non-volatile register to the value we + need in the stub body that follows. */ + +#if defined (__PPC__) + +/* Use r15 for PPC. Note that r14 is inappropriate here, even though it + is non-volatile according to the ABI, because GCC uses it as an extra + SCRATCH on SPE targets. */ #define CFA_REG 15 +#elif defined (__ARMEL__) + +/* Use r8 for ARM. Any of r4-r8 should work. */ + +#define CFA_REG 8 + +#else +Not_implemented; +#endif /* CFA setup block */ + #define CFI_DEF_CFA \ CR(".cfi_def_cfa " S(CFA_REG) ", 0") @@ -184,6 +241,8 @@ CR(".cfi_def_cfa " S(CFA_REG) ", 0") #define COMMON_CFI(REG) \ ".cfi_offset " S(REGNO_##REG) "," S(REG_SET_##REG) +#if defined (__PPC__) + #define CFI_COMMON_REGS \ CR("# CFI for common registers\n") \ TCR(COMMON_CFI(GR(0))) \ @@ -237,7 +296,7 @@ TCR("mflr %r0") \ TCR("stw %r0,20(%r1)") \ TCR("stw %r" S(CFA_REG) ",8(%r1)") \ TCR("") \ -TCR("# Setup CFA_REG = sc_pregs, that we'll retrieve as our CFA value") \ +TCR("# Setup CFA_REG = context, which we'll retrieve as our CFA value") \ TCR("mr %r" S(CFA_REG) ", %r7") \ TCR("") \ TCR("# Call the real handler. The signo, siginfo and sigcontext") \ @@ -253,12 +312,57 @@ TCR("") \ TCR("addi %r1,%r1,16") \ TCR("blr") +#elif defined (__ARMEL__) + +#define CFI_COMMON_REGS \ +CR("# CFI for common registers\n") \ +TCR(COMMON_CFI(G_REG_OFFSET(0))) \ +TCR(COMMON_CFI(G_REG_OFFSET(1))) \ +TCR(COMMON_CFI(G_REG_OFFSET(2))) \ +TCR(COMMON_CFI(G_REG_OFFSET(3))) \ +TCR(COMMON_CFI(G_REG_OFFSET(4))) \ +TCR(COMMON_CFI(G_REG_OFFSET(5))) \ +TCR(COMMON_CFI(G_REG_OFFSET(6))) \ +TCR(COMMON_CFI(G_REG_OFFSET(7))) \ +TCR(COMMON_CFI(G_REG_OFFSET(8))) \ +TCR(COMMON_CFI(G_REG_OFFSET(9))) \ +TCR(COMMON_CFI(G_REG_OFFSET(10))) \ +TCR(COMMON_CFI(G_REG_OFFSET(11))) \ +TCR(COMMON_CFI(G_REG_OFFSET(12))) \ +TCR(COMMON_CFI(G_REG_OFFSET(13))) \ +TCR(COMMON_CFI(G_REG_OFFSET(14))) \ +TCR(COMMON_CFI(PC_OFFSET)) \ +TCR(".cfi_return_column " S(REGNO_PC_OFFSET)) + +/* Trampoline body block + --------------------- */ + +#define SIGTRAMP_BODY \ +CR("") \ +TCR("# Allocate frame and save the non-volatile") \ +TCR("# registers we're going to modify") \ +TCR("mov ip, sp") \ +TCR("stmfd sp!, {r"S(CFA_REG)", fp, ip, lr, pc}") \ +TCR("# Setup CFA_REG = context, which we'll retrieve as our CFA value") \ +TCR("ldr r"S(CFA_REG)", [ip]") \ +TCR("") \ +TCR("# Call the real handler. The signo, siginfo and sigcontext") \ +TCR("# arguments are the same as those we received in r0, r1 and r2") \ +TCR("sub fp, ip, #4") \ +TCR("blx r3") \ +TCR("# Restore our callee-saved items, release our frame and return") \ +TCR("ldmfd sp, {r"S(CFA_REG)", fp, sp, pc}") + +#else +Not_implemented; +#endif /* CFI_COMMON_REGS and SIGTRAMP_BODY */ + /* Symbol definition block ----------------------- */ #define SIGTRAMP_START(SYM) \ CR("# " S(SYM) " cfi trampoline") \ -TCR(".type " S(SYM) ", @function") \ +TCR(".type " S(SYM) ", "FUNCTION) \ CR("") \ CR(S(SYM) ":") \ TCR(".cfi_startproc") \ diff --git a/main/gcc/ada/sinfo.adb b/main/gcc/ada/sinfo.adb index ec7a23f1125..ccbf87c58a9 100644 --- a/main/gcc/ada/sinfo.adb +++ b/main/gcc/ada/sinfo.adb @@ -1400,6 +1400,15 @@ package body Sinfo is return Flag4 (N); end From_At_Mod; + function From_Conditional_Expression + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_If_Statement); + return Flag1 (N); + end From_Conditional_Expression; + function From_Default (N : Node_Id) return Boolean is begin @@ -2373,6 +2382,14 @@ package body Sinfo is return Flag13 (N); end Null_Present; + function Null_Excluding_Subtype + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_To_Object_Definition); + return Flag16 (N); + end Null_Excluding_Subtype; + function Null_Exclusion_Present (N : Node_Id) return Boolean is begin @@ -2471,15 +2488,6 @@ package body Sinfo is return List3 (N); end Parameter_Associations; - function Parameter_List_Truncated - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Function_Call - or else NT (N).Nkind = N_Procedure_Call_Statement); - return Flag17 (N); - end Parameter_List_Truncated; - function Parameter_Specifications (N : Node_Id) return List_Id is begin @@ -3147,6 +3155,22 @@ package body Sinfo is return Node3 (N); end Type_Definition; + function Uneval_Old_Accept + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag7 (N); + end Uneval_Old_Accept; + + function Uneval_Old_Warn + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + return Flag18 (N); + end Uneval_Old_Warn; + function Unit (N : Node_Id) return Node_Id is begin @@ -4238,7 +4262,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_If_Expression); - Set_List3 (N, Val); -- semantic field, no parent set + Set_List3_With_Parent (N, Val); -- semantic field, but needs parents end Set_Else_Actions; procedure Set_Else_Statements @@ -4574,6 +4598,15 @@ package body Sinfo is Set_Flag4 (N, Val); end Set_From_At_Mod; + procedure Set_From_Conditional_Expression + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_If_Statement); + Set_Flag1 (N, Val); + end Set_From_Conditional_Expression; + procedure Set_From_Default (N : Node_Id; Val : Boolean := True) is begin @@ -5547,6 +5580,14 @@ package body Sinfo is Set_Flag13 (N, Val); end Set_Null_Present; + procedure Set_Null_Excluding_Subtype + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Access_To_Object_Definition); + Set_Flag16 (N, Val); + end Set_Null_Excluding_Subtype; + procedure Set_Null_Exclusion_Present (N : Node_Id; Val : Boolean := True) is begin @@ -5645,15 +5686,6 @@ package body Sinfo is Set_List3_With_Parent (N, Val); end Set_Parameter_Associations; - procedure Set_Parameter_List_Truncated - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Function_Call - or else NT (N).Nkind = N_Procedure_Call_Statement); - Set_Flag17 (N, Val); - end Set_Parameter_List_Truncated; - procedure Set_Parameter_Specifications (N : Node_Id; Val : List_Id) is begin @@ -6266,7 +6298,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_If_Expression); - Set_List2 (N, Val); -- semantic field, no parent set + Set_List2_With_Parent (N, Val); -- semantic field, but needs parents end Set_Then_Actions; procedure Set_Then_Statements @@ -6313,6 +6345,22 @@ package body Sinfo is Set_Elist3 (N, Val); -- semantic field, no parent set end Set_TSS_Elist; + procedure Set_Uneval_Old_Accept + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag7 (N, Val); + end Set_Uneval_Old_Accept; + + procedure Set_Uneval_Old_Warn + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Pragma); + Set_Flag18 (N, Val); + end Set_Uneval_Old_Warn; + procedure Set_Type_Definition (N : Node_Id; Val : Node_Id) is begin diff --git a/main/gcc/ada/sinfo.ads b/main/gcc/ada/sinfo.ads index 86d95305948..85a0d537225 100644 --- a/main/gcc/ada/sinfo.ads +++ b/main/gcc/ada/sinfo.ads @@ -562,12 +562,24 @@ package Sinfo is -- not make sense from a user point-of-view, and that cross-references that -- do not lead to data dependences for subprograms can be safely ignored. - -- In addition pragma Debug statements are removed from the tree (rewritten - -- to NULL stmt), since they should be ignored in formal verification. + -- GNATprove relies on the following frontend behaviors: - -- An error is also issued for missing subunits, similar to the warning - -- issued when generating code, to avoid formal verification of a partial - -- unit. + -- 1. The first declarations in the list of visible declarations of + -- a package declaration for a generic instance, up to the first + -- declaration which comes from source, should correspond to + -- the "mappings nodes" between formal and actual generic parameters. + + -- 2. In addition pragma Debug statements are removed from the tree + -- (rewritten to NULL stmt), since they should be ignored in formal + -- verification. + + -- 3. An error is also issued for missing subunits, similar to the + -- warning issued when generating code, to avoid formal verification + -- of a partial unit. + + -- 4. Unconstrained types are not replaced by constrained types whose + -- bounds are generated from an expression: Expand_Subtype_From_Expr + -- should be noop. ----------------------- -- Check Flag Fields -- @@ -809,7 +821,7 @@ package Sinfo is -- set, it means that the front end can assure no overlap of operands. -- Body_To_Inline (Node3-Sem) - -- present in subprogram declarations. Denotes analyzed but unexpanded + -- 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- @@ -1053,7 +1065,9 @@ package Sinfo is -- Initialization expression for the initial value in an object -- declaration. In this case the Do_Range_Check flag is set on -- the initialization expression, and the check is against the - -- range of the type of the object being declared. + -- range of the type of the object being declared. This includes the + -- cases of expressions providing default discriminant values, and + -- expressions used to initialize record components. -- The expression of a type conversion. In this case the range check is -- against the target type of the conversion. See also the use of @@ -1251,8 +1265,6 @@ package Sinfo is -- Float_Truncate (Flag11-Sem) -- A flag present in type conversion nodes. This is used for float to -- integer conversions where truncation is required rather than rounding. - -- Note that Gigi does not handle type conversions from real to integer - -- with rounding (see Expand_N_Type_Conversion). -- Forwards_OK (Flag5-Sem) -- A flag present in the N_Assignment_Statement node. It is used only @@ -1291,6 +1303,11 @@ package Sinfo is -- must be a multiple of the given value, and the representation clause -- is considered to be type specific instead of subtype specific. + -- From_Conditional_Expression (Flag1-Sem) + -- This flag is set on if and case statements generated by the expansion + -- of if and case expressions respectively. The flag is used to suppress + -- any finalization of controlled objects found within these statements. + -- From_Default (Flag6-Sem) -- This flag is set on the subprogram renaming declaration created in an -- instance for a formal subprogram, when the formal is declared with a @@ -1607,8 +1624,13 @@ package Sinfo is -- of an object allocated on the stack rather than the heap. -- Is_Static_Expression (Flag6-Sem) - -- Indicates that an expression is a static expression (RM 4.9). See spec - -- of package Sem_Eval for full details on the use of this flag. + -- Indicates that an expression is a static expression according to the + -- rules in (RM 4.9). Note that it is possible for this flag to be set + -- when Raises_Constraint_Error is also set. In practice almost all cases + -- where a static expression is required do not allow an expression which + -- raises Constraint_Error, so almost always, callers should call the + -- Is_Ok_Static_Expression routine instead of testing this flag. See + -- spec of package Sem_Eval for full details on the use of this flag. -- Is_Subprogram_Descriptor (Flag16-Sem) -- Present in N_Object_Declaration, and set only for the object @@ -1667,6 +1689,8 @@ package Sinfo is -- -- For a subunit, Library_Unit points to the compilation unit node of -- the parent body. + -- ??? not (always) true, in (at least some, maybe all?) cases it points + -- to the corresponding spec for the parent body. -- -- Note that this field is not used to hold the parent pointer for child -- unit (which might in any case need to use it for some other purpose as @@ -1840,6 +1864,11 @@ package Sinfo is -- expected type is a thin pointer to unconstrained array. This flag is -- to assist in detecting this illegal use of Unrestricted_Access. + -- Null_Excluding_Subtype (Flag16) + -- Present in N_Access_To_Object_Definition. Indicates that the subtype + -- indication carries a null-exclusion indicator, which is distinct from + -- the null-exclusion indicator that may precede the access keyword. + -- Original_Discriminant (Node2-Sem) -- Present in identifiers. Used in references to discriminants that -- appear in generic units. Because the names of the discriminants may be @@ -1865,21 +1894,6 @@ package Sinfo is -- list of discrete choices, except that of course it cannot contain an -- N_Others_Choice entry. - -- Parameter_List_Truncated (Flag17-Sem) - -- Present in N_Function_Call and N_Procedure_Call_Statement nodes. Set - -- (for OpenVMS ports of GNAT only) if the parameter list is truncated - -- as a result of a First_Optional_Parameter specification in one of the - -- pragmas Import_Function, Import_Procedure, or Import_Valued_Procedure. - -- The truncation is done by the expander by removing trailing parameters - -- from the argument list, in accordance with the set of rules allowing - -- such parameter removal. In particular, parameters can be removed - -- working from the end of the parameter list backwards up to and - -- including the entry designated by First_Optional_Parameter in the - -- Import pragma. Parameters can be removed if they are implicit and the - -- default value is known at compile time value, including the use of - -- the Null_Parameter attribute, or if explicit parameter values are - -- present that match the corresponding defaults. - -- 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 @@ -2029,7 +2043,9 @@ package Sinfo is -- and range checks in cases where the generated code knows that the -- value being assigned is in range and satisfies any predicate. Also -- can be set in N_Object_Declaration nodes, to similarly suppress any - -- checks on the initializing value. + -- checks on the initializing value. In assignment statements it also + -- suppresses access checks in the generated code for out- and in-out + -- parameters in entry calls. -- Suppress_Loop_Warnings (Flag17-Sem) -- Used in N_Loop_Statement node to indicate that warnings within the @@ -2075,6 +2091,20 @@ package Sinfo is -- if there are no type support subprograms for the type or if the freeze -- node is not for a type. + -- Uneval_Old_Accept (Flag7-Sem) + -- Present in N_Pragma nodes. Set True if Opt.Uneval_Old is set to 'A' + -- (accept) at the point where the pragma is encountered (including the + -- case of a pragma generated from an aspect specification). It is this + -- setting that is relevant, rather than the setting at the point where + -- a contract is finally analyzed after the delay till the freeze point. + + -- Uneval_Old_Warn (Flag18-Sem) + -- Present in N_Pragma nodes. Set True if Opt.Uneval_Old is set to 'W' + -- (warn) at the point where the pragma is encountered (including the + -- case of a pragma generated from an aspect specification). It is this + -- setting that is relevant, rather than the setting at the point where + -- a contract is finally analyzed after the delay till the freeze point. + -- Unreferenced_In_Spec (Flag7-Sem) -- Present in N_With_Clause nodes. Set if the with clause is on the -- package or subprogram spec where the main unit is the corresponding @@ -2367,6 +2397,8 @@ package Sinfo is -- Is_Checked (Flag11-Sem) -- Import_Interface_Present (Flag16-Sem) -- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set + -- Uneval_Old_Accept (Flag7-Sem) + -- Uneval_Old_Warn (Flag18-Sem) -- Note: we should have a section on what pragmas are passed on to -- the back end to be processed. This section should note that pragma @@ -3359,6 +3391,7 @@ package Sinfo is -- Sloc points to ACCESS -- All_Present (Flag15) -- Null_Exclusion_Present (Flag11) + -- Null_Excluding_Subtype (Flag16) -- Subtype_Indication (Node5) -- Constant_Present (Flag17) @@ -4261,8 +4294,17 @@ package Sinfo is -- (explicitly set to True if missing). -- Note: the Then_Actions and Else_Actions fields are always set to - -- No_List in the tree passed to Gigi. These fields are used only - -- for temporary processing purposes in the expander. + -- No_List in the tree passed to the back end. These are used only + -- for temporary processing purposes in the expander. Even though they + -- are semantic fields, their parent pointers are set because analysis + -- of actions nodes in those lists may generate additional actions that + -- need to know their insertion point (for example for the creation of + -- transient scopes). + + -- Note: in the tree passed to the back end, if the result type is + -- an unconstrained array, the if expression can only appears in the + -- initializing expression of an object declaration (this avoids the + -- back end having to create a variable length temporary on the fly). ---------------------------- -- 4.5.7 Case Expression -- @@ -4565,6 +4607,7 @@ package Sinfo is -- Elsif_Parts (List3) (set to No_List if none present) -- Else_Statements (List4) (set to No_List if no else part present) -- End_Span (Uint5) (set to Uint_0 if expander generated) + -- From_Conditional_Expression (Flag1-Sem) -- N_Elsif_Part -- Sloc points to ELSIF @@ -4597,6 +4640,7 @@ package Sinfo is -- Expression (Node3) -- Alternatives (List4) -- End_Span (Uint5) (set to Uint_0 if expander generated) + -- From_Conditional_Expression (Flag1-Sem) -- Note: Before Ada 2012, a pragma in a statement sequence is always -- followed by a statement, and this is true in the tree even in Ada @@ -5103,7 +5147,6 @@ package Sinfo is -- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching) -- Do_Tag_Check (Flag13-Sem) -- No_Elaboration_Check (Flag14-Sem) - -- Parameter_List_Truncated (Flag17-Sem) -- ABE_Is_Certain (Flag18-Sem) -- plus fields for expression @@ -5135,7 +5178,6 @@ package Sinfo is -- Is_Expanded_Build_In_Place_Call (Flag11-Sem) -- Do_Tag_Check (Flag13-Sem) -- No_Elaboration_Check (Flag14-Sem) - -- Parameter_List_Truncated (Flag17-Sem) -- ABE_Is_Certain (Flag18-Sem) -- plus fields for expression @@ -7091,14 +7133,14 @@ package Sinfo is -- Aspect_Rep_Item (Node2-Sem) -- Expression (Node3) Aspect_Definition (set to Empty if none) -- Entity (Node4-Sem) entity to which the aspect applies - -- Class_Present (Flag6) Set if 'Class present -- Next_Rep_Item (Node5-Sem) - -- Split_PPC (Flag17) Set if split pre/post attribute - -- Is_Boolean_Aspect (Flag16-Sem) + -- Class_Present (Flag6) Set if 'Class present + -- Is_Ignored (Flag9-Sem) -- Is_Checked (Flag11-Sem) -- Is_Delayed_Aspect (Flag14-Sem) -- Is_Disabled (Flag15-Sem) - -- Is_Ignored (Flag9-Sem) + -- Is_Boolean_Aspect (Flag16-Sem) + -- Split_PPC (Flag17) Set if split pre/post attribute -- Note: Aspect_Specification is an Ada 2012 feature @@ -9027,6 +9069,9 @@ package Sinfo is function From_At_Mod (N : Node_Id) return Boolean; -- Flag4 + function From_Conditional_Expression + (N : Node_Id) return Boolean; -- Flag1 + function From_Default (N : Node_Id) return Boolean; -- Flag6 @@ -9344,6 +9389,9 @@ package Sinfo is function Null_Present (N : Node_Id) return Boolean; -- Flag13 + function Null_Excluding_Subtype + (N : Node_Id) return Boolean; -- Flag16 + function Null_Exclusion_Present (N : Node_Id) return Boolean; -- Flag11 @@ -9374,9 +9422,6 @@ package Sinfo is function Parameter_Associations (N : Node_Id) return List_Id; -- List3 - function Parameter_List_Truncated - (N : Node_Id) return Boolean; -- Flag17 - function Parameter_Specifications (N : Node_Id) return List_Id; -- List3 @@ -9581,6 +9626,12 @@ package Sinfo is function Type_Definition (N : Node_Id) return Node_Id; -- Node3 + function Uneval_Old_Accept + (N : Node_Id) return Boolean; -- Flag7 + + function Uneval_Old_Warn + (N : Node_Id) return Boolean; -- Flag18 + function Unit (N : Node_Id) return Node_Id; -- Node2 @@ -10028,15 +10079,18 @@ package Sinfo is procedure Set_Forwards_OK (N : Node_Id; Val : Boolean := True); -- Flag5 - procedure Set_From_At_Mod - (N : Node_Id; Val : Boolean := True); -- Flag4 - procedure Set_From_Aspect_Specification (N : Node_Id; Val : Boolean := True); -- Flag13 procedure Set_From_At_End (N : Node_Id; Val : Boolean := True); -- Flag4 + procedure Set_From_At_Mod + (N : Node_Id; Val : Boolean := True); -- Flag4 + + procedure Set_From_Conditional_Expression + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_From_Default (N : Node_Id; Val : Boolean := True); -- Flag6 @@ -10355,6 +10409,9 @@ package Sinfo is procedure Set_Null_Present (N : Node_Id; Val : Boolean := True); -- Flag13 + procedure Set_Null_Excluding_Subtype + (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Null_Exclusion_Present (N : Node_Id; Val : Boolean := True); -- Flag11 @@ -10385,9 +10442,6 @@ package Sinfo is procedure Set_Parameter_Associations (N : Node_Id; Val : List_Id); -- List3 - procedure Set_Parameter_List_Truncated - (N : Node_Id; Val : Boolean := True); -- Flag17 - procedure Set_Parameter_Specifications (N : Node_Id; Val : List_Id); -- List3 @@ -10592,6 +10646,12 @@ package Sinfo is procedure Set_Type_Definition (N : Node_Id; Val : Node_Id); -- Node3 + procedure Set_Uneval_Old_Accept + (N : Node_Id; Val : Boolean := True); -- Flag7 + + procedure Set_Uneval_Old_Warn + (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Unit (N : Node_Id; Val : Node_Id); -- Node2 @@ -12523,6 +12583,7 @@ package Sinfo is pragma Inline (From_Aspect_Specification); pragma Inline (From_At_End); pragma Inline (From_At_Mod); + pragma Inline (From_Conditional_Expression); pragma Inline (From_Default); pragma Inline (Generalized_Indexing); pragma Inline (Generic_Associations); @@ -12629,6 +12690,7 @@ package Sinfo is pragma Inline (No_Truncation); pragma Inline (Non_Aliased_Prefix); pragma Inline (Null_Present); + pragma Inline (Null_Excluding_Subtype); pragma Inline (Null_Exclusion_Present); pragma Inline (Null_Exclusion_In_Return_Present); pragma Inline (Null_Record_Present); @@ -12640,7 +12702,6 @@ package Sinfo is pragma Inline (Out_Present); pragma Inline (Parameter_Associations); pragma Inline (Parameter_Specifications); - pragma Inline (Parameter_List_Truncated); pragma Inline (Parameter_Type); pragma Inline (Parent_Spec); pragma Inline (Position); @@ -12708,6 +12769,8 @@ package Sinfo is pragma Inline (Treat_Fixed_As_Integer); pragma Inline (TSS_Elist); pragma Inline (Type_Definition); + pragma Inline (Uneval_Old_Accept); + pragma Inline (Uneval_Old_Warn); pragma Inline (Unit); pragma Inline (Uninitialized_Variable); pragma Inline (Unknown_Discriminants_Present); @@ -12857,6 +12920,7 @@ package Sinfo is pragma Inline (Set_From_Aspect_Specification); pragma Inline (Set_From_At_End); pragma Inline (Set_From_At_Mod); + pragma Inline (Set_From_Conditional_Expression); pragma Inline (Set_From_Default); pragma Inline (Set_Generalized_Indexing); pragma Inline (Set_Generic_Associations); @@ -12961,6 +13025,7 @@ package Sinfo is pragma Inline (Set_No_Minimize_Eliminate); pragma Inline (Set_No_Truncation); pragma Inline (Set_Non_Aliased_Prefix); + pragma Inline (Set_Null_Excluding_Subtype); pragma Inline (Set_Null_Exclusion_Present); pragma Inline (Set_Null_Exclusion_In_Return_Present); pragma Inline (Set_Null_Present); @@ -12972,7 +13037,6 @@ package Sinfo is pragma Inline (Set_Others_Discrete_Choices); pragma Inline (Set_Out_Present); pragma Inline (Set_Parameter_Associations); - pragma Inline (Set_Parameter_List_Truncated); pragma Inline (Set_Parameter_Specifications); pragma Inline (Set_Parameter_Type); pragma Inline (Set_Parent_Spec); @@ -13039,6 +13103,8 @@ package Sinfo is pragma Inline (Set_Triggering_Alternative); pragma Inline (Set_Triggering_Statement); pragma Inline (Set_Type_Definition); + pragma Inline (Set_Uneval_Old_Accept); + pragma Inline (Set_Uneval_Old_Warn); pragma Inline (Set_Unit); pragma Inline (Set_Uninitialized_Variable); pragma Inline (Set_Unknown_Discriminants_Present); diff --git a/main/gcc/ada/sinput-c.adb b/main/gcc/ada/sinput-c.adb index 06c501bef25..6c3d58254fe 100644 --- a/main/gcc/ada/sinput-c.adb +++ b/main/gcc/ada/sinput-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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 Sinput.C is Len := Integer (File_Length (Source_File_FD)); - -- Set Hi so that length is one more than the physical length, - -- allowing for the extra EOF character at the end of the buffer + -- Set Hi so that length is one more than the physical length, allowing + -- for the extra EOF character at the end of the buffer Hi := Lo + Source_Ptr (Len); @@ -112,9 +112,9 @@ package body Sinput.C is begin -- Allocate source buffer, allowing extra character at end for EOF - -- Some systems (e.g. VMS) have file types that require one - -- read per line, so read until we get the Len bytes or until - -- there are no more characters. + -- Some systems have file types that require one read per line, + -- so read until we get the Len bytes or until there are no more + -- characters. Hi := Lo; loop @@ -126,8 +126,8 @@ package body Sinput.C is Actual_Ptr (Hi) := EOF; -- Now we need to work out the proper virtual origin pointer to - -- return. This is exactly Actual_Ptr (0)'Address, but we have - -- to be careful to suppress checks to compute this address. + -- return. This is exactly Actual_Ptr (0)'Address, but we have to + -- be careful to suppress checks to compute this address. declare pragma Suppress (All_Checks); diff --git a/main/gcc/ada/sinput.adb b/main/gcc/ada/sinput.adb index dac8dd809a8..1c8232d1c83 100644 --- a/main/gcc/ada/sinput.adb +++ b/main/gcc/ada/sinput.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 +302,17 @@ package body Sinput is end case; end Check_For_BOM; + ----------------------------- + -- Comes_From_Inlined_Body -- + ----------------------------- + + function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean is + SIE : Source_File_Record renames + Source_File.Table (Get_Source_File_Index (S)); + begin + return SIE.Inlined_Body; + end Comes_From_Inlined_Body; + ----------------------- -- Get_Column_Number -- ----------------------- @@ -331,11 +342,22 @@ package body Sinput is while S < P loop if Src (S) = HT then C := (C - 1) / 8 * 8 + (8 + 1); + S := S + 1; + + -- Deal with wide character case, but don't include brackets + -- notation in this circuit, since we know that this will + -- display unencoded (no one encodes brackets notation). + + elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then + C := C + 1; + Skip_Wide (Src, S); + + -- Normal (non-wide) character case or brackets sequence + else C := C + 1; + S := S + 1; end if; - - S := S + 1; end loop; return C; diff --git a/main/gcc/ada/sinput.ads b/main/gcc/ada/sinput.ads index 899bead7339..3d36903bb05 100644 --- a/main/gcc/ada/sinput.ads +++ b/main/gcc/ada/sinput.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -638,6 +638,13 @@ package Sinput is -- value of the instantiation if this location is within an instance. -- If S is not within an instance, then this returns No_Location. + function Comes_From_Inlined_Body (S : Source_Ptr) return Boolean; + pragma Inline (Comes_From_Inlined_Body); + -- Given a source pointer S, returns whether it comes from an inlined body. + -- 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 diff --git a/main/gcc/ada/snames.adb-tmpl b/main/gcc/ada/snames.adb-tmpl index 5a6cfbaada7..b0b5249851a 100644 --- a/main/gcc/ada/snames.adb-tmpl +++ b/main/gcc/ada/snames.adb-tmpl @@ -217,33 +217,32 @@ package body Snames is function Get_Pragma_Id (N : Name_Id) return Pragma_Id is begin - if N = Name_AST_Entry then - return Pragma_AST_Entry; - elsif N = Name_CPU then - return Pragma_CPU; - elsif N = Name_Dispatching_Domain then - return Pragma_Dispatching_Domain; - elsif N = Name_Fast_Math then - return Pragma_Fast_Math; - elsif N = Name_Interface then - return Pragma_Interface; - elsif N = Name_Interrupt_Priority then - return Pragma_Interrupt_Priority; - elsif N = Name_Lock_Free then - return Pragma_Lock_Free; - elsif N = Name_Priority then - return Pragma_Priority; - elsif N = Name_Relative_Deadline then - return Pragma_Relative_Deadline; - elsif N = Name_Storage_Size then - return Pragma_Storage_Size; - elsif N = Name_Storage_Unit then - return Pragma_Storage_Unit; - elsif N not in First_Pragma_Name .. Last_Pragma_Name then - return Unknown_Pragma; - else - return Pragma_Id'Val (N - First_Pragma_Name); - end if; + case N is + when Name_CPU => + return Pragma_CPU; + when Name_Default_Scalar_Storage_Order => + return Pragma_Default_Scalar_Storage_Order; + when Name_Dispatching_Domain => + return Pragma_Dispatching_Domain; + when Name_Fast_Math => + return Pragma_Fast_Math; + when Name_Interface => + return Pragma_Interface; + when Name_Interrupt_Priority => + return Pragma_Interrupt_Priority; + when Name_Lock_Free => + return Pragma_Lock_Free; + when Name_Priority => + return Pragma_Priority; + when Name_Storage_Size => + return Pragma_Storage_Size; + when Name_Storage_Unit => + return Pragma_Storage_Unit; + when First_Pragma_Name .. Last_Pragma_Name => + return Pragma_Id'Val (N - First_Pragma_Name); + when others => + return Unknown_Pragma; + end case; end Get_Pragma_Id; --------------------------- @@ -338,6 +337,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 + or else N = Name_Default_Scalar_Storage_Order or else N = Name_Fast_Math; end Is_Configuration_Pragma_Name; @@ -449,8 +449,8 @@ package body Snames is function Is_Pragma_Name (N : Name_Id) return Boolean is begin return N in First_Pragma_Name .. Last_Pragma_Name - or else N = Name_AST_Entry or else N = Name_CPU + or else N = Name_Default_Scalar_Storage_Order or else N = Name_Dispatching_Domain or else N = Name_Fast_Math or else N = Name_Interface diff --git a/main/gcc/ada/snames.ads-tmpl b/main/gcc/ada/snames.ads-tmpl index f4b5faca91a..c1b62b29e3a 100644 --- a/main/gcc/ada/snames.ads-tmpl +++ b/main/gcc/ada/snames.ads-tmpl @@ -56,8 +56,8 @@ package Snames is -- First we have the one character names used to optimize the lookup -- process for one character identifiers (to avoid the hashing in this - -- case) There are a full 256 of these, but only the entries for lower case - -- and upper case letters have identifiers + -- case) There are a full 256 of these, but only the entries for lower + -- case and upper case letters have identifiers -- The lower case letter entries are used for one character identifiers -- appearing in the source, for example in pragma Interface (C). @@ -329,7 +329,7 @@ package Snames is -- to be implementation dependent pragmas. -- The entries marked GNAT are pragmas that are defined by GNAT and that - -- are implemented in all modes (Ada 83, Ada 95, and Ada 2005) Complete + -- are implemented in all modes (Ada 83, Ada 95, and Ada 2005). Complete -- descriptions of the syntax of these implementation dependent pragmas may -- be found in the appropriate section in unit Sem_Prag in file -- sem-prag.adb, and they are documented in the GNAT reference manual. @@ -342,10 +342,6 @@ package Snames is -- Ada 83, Ada 95, and Ada 2005 mode as well, where they are technically -- considered to be implementation dependent pragmas. - -- The entries marked VMS are VMS specific pragmas that are recognized only - -- in OpenVMS versions of GNAT. They are ignored in other versions with an - -- appropriate warning. - -- The entries marked AAMP are AAMP specific pragmas that are recognized -- only in GNAT for the AAMP. They are ignored in other versions with -- appropriate warnings. @@ -380,7 +376,6 @@ package Snames is Name_Convention_Identifier : constant Name_Id := N + $; -- GNAT Name_Debug_Policy : constant Name_Id := N + $; -- GNAT Name_Detect_Blocking : constant Name_Id := N + $; -- Ada 05 - Name_Default_Scalar_Storage_Order : constant Name_Id := N + $; -- GNAT Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12 Name_Disable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT Name_Discard_Names : constant Name_Id := N + $; @@ -405,13 +400,11 @@ package Snames is -- Fast_Math. Name_Favor_Top_Level : constant Name_Id := N + $; -- GNAT - Name_Float_Representation : constant Name_Id := N + $; -- GNAT Name_Implicit_Packing : constant Name_Id := N + $; -- GNAT Name_Initialize_Scalars : constant Name_Id := N + $; -- GNAT Name_Interrupt_State : constant Name_Id := N + $; -- GNAT Name_License : constant Name_Id := N + $; -- GNAT Name_Locking_Policy : constant Name_Id := N + $; - Name_Long_Float : constant Name_Id := N + $; -- VMS Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT @@ -442,6 +435,7 @@ package Snames is Name_Suppress : constant Name_Id := N + $; Name_Suppress_Exception_Locations : constant Name_Id := N + $; -- GNAT Name_Task_Dispatching_Policy : constant Name_Id := N + $; + Name_Unevaluated_Use_Of_Old : constant Name_Id := N + $; -- GNAT Name_Universal_Data : constant Name_Id := N + $; -- AAMP Name_Unsuppress : constant Name_Id := N + $; -- Ada 05 Name_Use_VADS_Size : constant Name_Id := N + $; -- GNAT @@ -456,12 +450,6 @@ package Snames is Name_Abort_Defer : constant Name_Id := N + $; -- GNAT Name_Abstract_State : constant Name_Id := N + $; -- GNAT Name_All_Calls_Remote : constant Name_Id := N + $; - - -- Note: AST_Entry is not in this list because its name matches the name of - -- the corresponding attribute. However, it is included in the definition - -- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id - -- correctly recognize and process Name_AST_Entry. - Name_Assert : constant Name_Id := N + $; -- Ada 05 Name_Assert_And_Cut : constant Name_Id := N + $; -- GNAT Name_Async_Readers : constant Name_Id := N + $; -- GNAT @@ -491,6 +479,7 @@ package Snames is -- pragma. Name_Debug : constant Name_Id := N + $; -- GNAT + Name_Default_Initial_Condition : constant Name_Id := N + $; -- GNAT Name_Depends : constant Name_Id := N + $; -- GNAT Name_Effective_Reads : constant Name_Id := N + $; -- GNAT Name_Effective_Writes : constant Name_Id := N + $; -- GNAT @@ -498,7 +487,6 @@ package Snames is Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_Body : constant Name_Id := N + $; Name_Export : constant Name_Id := N + $; - Name_Export_Exception : constant Name_Id := N + $; -- VMS Name_Export_Function : constant Name_Id := N + $; -- GNAT Name_Export_Object : constant Name_Id := N + $; -- GNAT Name_Export_Procedure : constant Name_Id := N + $; -- GNAT @@ -507,11 +495,10 @@ package Snames is Name_External : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT Name_Global : constant Name_Id := N + $; -- GNAT - Name_Ident : constant Name_Id := N + $; -- VMS + Name_Ident : constant Name_Id := N + $; -- GNAT Name_Implementation_Defined : constant Name_Id := N + $; -- GNAT Name_Implemented : constant Name_Id := N + $; -- Ada 12 Name_Import : constant Name_Id := N + $; - Name_Import_Exception : constant Name_Id := N + $; -- VMS Name_Import_Function : constant Name_Id := N + $; -- GNAT Name_Import_Object : constant Name_Id := N + $; -- GNAT Name_Import_Procedure : constant Name_Id := N + $; -- GNAT @@ -562,6 +549,7 @@ package Snames is Name_Main_Storage : 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 Name_No_Inline : constant Name_Id := N + $; -- GNAT Name_No_Return : constant Name_Id := N + $; -- Ada 05 Name_Obsolescent : constant Name_Id := N + $; -- GNAT @@ -588,7 +576,7 @@ package Snames is -- pragma. Name_Provide_Shift_Operators : constant Name_Id := N + $; -- GNAT - Name_Psect_Object : constant Name_Id := N + $; -- VMS + Name_Psect_Object : constant Name_Id := N + $; -- GNAT Name_Pure : constant Name_Id := N + $; Name_Pure_Function : constant Name_Id := N + $; -- GNAT Name_Refined_Depends : constant Name_Id := N + $; -- GNAT @@ -623,7 +611,7 @@ package Snames is Name_Test_Case : constant Name_Id := N + $; -- GNAT Name_Task_Info : constant Name_Id := N + $; -- GNAT Name_Task_Name : constant Name_Id := N + $; -- GNAT - Name_Task_Storage : constant Name_Id := N + $; -- VMS + Name_Task_Storage : constant Name_Id := N + $; -- GNAT Name_Thread_Local_Storage : constant Name_Id := N + $; -- GNAT Name_Time_Slice : constant Name_Id := N + $; -- GNAT Name_Title : constant Name_Id := N + $; -- GNAT @@ -687,6 +675,7 @@ package Snames is -- Other special names used in processing pragmas + Name_Allow : constant Name_Id := N + $; Name_Amount : constant Name_Id := N + $; Name_As_Is : constant Name_Id := N + $; Name_Assertion : constant Name_Id := N + $; @@ -705,7 +694,6 @@ package Snames is Name_Copy : constant Name_Id := N + $; Name_D_Float : constant Name_Id := N + $; Name_Decreases : constant Name_Id := N + $; - Name_Descriptor : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $; Name_Dot_Replacement : constant Name_Id := N + $; Name_Dynamic : constant Name_Id := N + $; @@ -750,6 +738,7 @@ package Snames is Name_No_Dependence : constant Name_Id := N + $; Name_No_Dynamic_Attachment : constant Name_Id := N + $; Name_No_Dynamic_Interrupts : constant Name_Id := N + $; + Name_No_Elaboration_Code : constant Name_Id := N + $; Name_No_Implementation_Extensions : constant Name_Id := N + $; Name_No_Obsolescent_Features : constant Name_Id := N + $; Name_No_Requeue : constant Name_Id := N + $; @@ -781,7 +770,6 @@ package Snames is Name_Secondary_Stack_Size : constant Name_Id := N + $; Name_Section : constant Name_Id := N + $; Name_Semaphore : constant Name_Id := N + $; - Name_Short_Descriptor : constant Name_Id := N + $; Name_Simple_Barriers : constant Name_Id := N + $; Name_SPARK : constant Name_Id := N + $; Name_SPARK_05 : constant Name_Id := N + $; @@ -809,8 +797,8 @@ package Snames is Name_Variant : constant Name_Id := N + $; Name_VAX_Float : constant Name_Id := N + $; Name_Vector : constant Name_Id := N + $; - Name_VMS : constant Name_Id := N + $; Name_Vtable_Ptr : constant Name_Id := N + $; + Name_Warn : constant Name_Id := N + $; Name_Working_Storage : constant Name_Id := N + $; -- Names of recognized attributes. The entries with the comment "Ada 83" @@ -821,9 +809,6 @@ package Snames is -- implemented in all Ada modes. Full descriptions of these implementation -- dependent attributes may be found in the appropriate Sem_Attr section. - -- The entries marked VMS are recognized only in OpenVMS implementations - -- of GNAT, and are treated as illegal in all other contexts. - First_Attribute_Name : constant Name_Id := N + $; Name_Abort_Signal : constant Name_Id := N + $; -- GNAT Name_Access : constant Name_Id := N + $; @@ -833,7 +818,6 @@ package Snames is Name_Alignment : constant Name_Id := N + $; Name_Asm_Input : constant Name_Id := N + $; -- GNAT Name_Asm_Output : constant Name_Id := N + $; -- GNAT - Name_AST_Entry : constant Name_Id := N + $; -- VMS Name_Atomic_Always_Lock_Free : constant Name_Id := N + $; -- GNAT Name_Bit : constant Name_Id := N + $; -- GNAT Name_Bit_Order : constant Name_Id := N + $; @@ -849,6 +833,7 @@ package Snames is Name_Constrained : constant Name_Id := N + $; Name_Count : constant Name_Id := N + $; Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT + Name_Default_Scalar_Storage_Order : constant Name_Id := N + $; -- GNAT Name_Default_Iterator : constant Name_Id := N + $; -- GNAT Name_Definite : constant Name_Id := N + $; Name_Delta : constant Name_Id := N + $; @@ -914,7 +899,7 @@ package Snames is Name_Overlaps_Storage : constant Name_Id := N + $; -- GNAT Name_Partition_ID : constant Name_Id := N + $; Name_Passed_By_Reference : constant Name_Id := N + $; -- GNAT - Name_Pool_Address : constant Name_Id := N + $; + Name_Pool_Address : constant Name_Id := N + $; -- GNAT Name_Pos : constant Name_Id := N + $; Name_Position : constant Name_Id := N + $; Name_Priority : constant Name_Id := N + $; -- Ada 05 @@ -934,7 +919,7 @@ package Snames is Name_Scaling : constant Name_Id := N + $; Name_Signed_Zeros : constant Name_Id := N + $; Name_Size : constant Name_Id := N + $; - Name_Small : constant Name_Id := N + $; + Name_Small : constant Name_Id := N + $; -- Ada 83 Name_Storage_Size : constant Name_Id := N + $; Name_Storage_Unit : constant Name_Id := N + $; -- GNAT Name_Stream_Size : constant Name_Id := N + $; -- Ada 05 @@ -948,7 +933,7 @@ package Snames is Name_UET_Address : constant Name_Id := N + $; -- GNAT Name_Unbiased_Rounding : constant Name_Id := N + $; Name_Unchecked_Access : constant Name_Id := N + $; - Name_Unconstrained_Array : constant Name_Id := N + $; + Name_Unconstrained_Array : constant Name_Id := N + $; -- GNAT Name_Universal_Literal_String : constant Name_Id := N + $; -- GNAT Name_Unrestricted_Access : constant Name_Id := N + $; -- GNAT Name_Update : constant Name_Id := N + $; -- GNAT @@ -1021,7 +1006,7 @@ package Snames is First_Type_Attribute_Name : constant Name_Id := N + $; Name_Base : constant Name_Id := N + $; Name_Class : constant Name_Id := N + $; - Name_Stub_Type : constant Name_Id := N + $; + Name_Stub_Type : constant Name_Id := N + $; -- GNAT Last_Type_Attribute_Name : constant Name_Id := N + $; Last_Entity_Attribute_Name : constant Name_Id := N + $; Last_Attribute_Name : constant Name_Id := N + $; @@ -1184,6 +1169,8 @@ package Snames is -- convention name. So is To_Address, which is a GNAT attribute. First_Intrinsic_Name : constant Name_Id := N + $; + Name_Compilation_Date : constant Name_Id := N + $; + Name_Compilation_Time : constant Name_Id := N + $; Name_Divide : constant Name_Id := N + $; Name_Enclosing_Entity : constant Name_Id := N + $; Name_Exception_Information : constant Name_Id := N + $; @@ -1461,7 +1448,6 @@ package Snames is Attribute_Alignment, Attribute_Asm_Input, Attribute_Asm_Output, - Attribute_AST_Entry, Attribute_Atomic_Always_Lock_Free, Attribute_Bit, Attribute_Bit_Order, @@ -1477,6 +1463,7 @@ package Snames is Attribute_Constrained, Attribute_Count, Attribute_Default_Bit_Order, + Attribute_Default_Scalar_Storage_Order, Attribute_Default_Iterator, Attribute_Definite, Attribute_Delta, @@ -1743,7 +1730,6 @@ package Snames is Pragma_Convention_Identifier, Pragma_Debug_Policy, Pragma_Detect_Blocking, - Pragma_Default_Scalar_Storage_Order, Pragma_Default_Storage_Pool, Pragma_Disable_Atomic_Synchronization, Pragma_Discard_Names, @@ -1754,13 +1740,11 @@ package Snames is Pragma_Extensions_Allowed, Pragma_External_Name_Casing, Pragma_Favor_Top_Level, - Pragma_Float_Representation, Pragma_Implicit_Packing, Pragma_Initialize_Scalars, Pragma_Interrupt_State, Pragma_License, Pragma_Locking_Policy, - Pragma_Long_Float, Pragma_Loop_Optimize, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, @@ -1791,6 +1775,7 @@ package Snames is Pragma_Suppress, Pragma_Suppress_Exception_Locations, Pragma_Task_Dispatching_Policy, + Pragma_Unevaluated_Use_Of_Old, Pragma_Universal_Data, Pragma_Unsuppress, Pragma_Use_VADS_Size, @@ -1826,6 +1811,7 @@ package Snames is Pragma_CPP_Virtual, Pragma_CPP_Vtable, Pragma_Debug, + Pragma_Default_Initial_Condition, Pragma_Depends, Pragma_Effective_Reads, Pragma_Effective_Writes, @@ -1833,7 +1819,6 @@ package Snames is Pragma_Elaborate_All, Pragma_Elaborate_Body, Pragma_Export, - Pragma_Export_Exception, Pragma_Export_Function, Pragma_Export_Object, Pragma_Export_Procedure, @@ -1846,7 +1831,6 @@ package Snames is Pragma_Implementation_Defined, Pragma_Implemented, Pragma_Import, - Pragma_Import_Exception, Pragma_Import_Function, Pragma_Import_Object, Pragma_Import_Procedure, @@ -1879,6 +1863,7 @@ package Snames is Pragma_Main_Storage, Pragma_Memory_Size, Pragma_No_Body, + Pragma_No_Elaboration_Code_All, Pragma_No_Inline, Pragma_No_Return, Pragma_Obsolescent, @@ -1945,8 +1930,8 @@ package Snames is -- special processing required to deal with the fact that their names -- match existing attribute names. - Pragma_AST_Entry, Pragma_CPU, + Pragma_Default_Scalar_Storage_Order, Pragma_Dispatching_Domain, Pragma_Fast_Math, Pragma_Interface, @@ -2038,12 +2023,12 @@ package Snames is -- Test to see if the name N is the name of an operator symbol function Is_Pragma_Name (N : Name_Id) return Boolean; - -- Test to see if the name N is the name of a recognized pragma. Note that - -- pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math, - -- Interrupt_Priority, Lock_Free, Priority, Storage_Size, and Storage_Unit - -- are recognized as pragmas by this function even though their names are - -- separate from the other pragma names. For this reason, clients should - -- always use this function, rather than do range tests on Name_Id values. + -- Test to see if the name N is the name of a recognized pragma. Note + -- that pragmas CPU, Dispatching_Domain, Fast_Math, Interrupt_Priority, + -- Lock_Free, Priority, Storage_Size, and Storage_Unit are recognized + -- as pragmas by this function even though their names are separate from + -- the other pragma names. For this reason, clients should always use + -- this function, rather than do range tests on Name_Id values. function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean; -- Test to see if the name N is the name of a recognized configuration @@ -2083,10 +2068,8 @@ package Snames is -- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma -- if N is not a name of a known (Ada defined or GNAT-specific) pragma. -- Note that the function also works correctly for names of pragmas that - -- are not included in the main list of pragma Names (AST_Entry, CPU, - -- Dispatching_Domain, Interrupt_Priority, Lock_Free, Priority, - -- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns - -- Pragma_Storage_Size). + -- are not included in the main list of pragma Names (e.g. Name_CPU returns + -- Pragma_CPU). function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id; -- Returns Id of queuing policy corresponding to given name. It is an error diff --git a/main/gcc/ada/socket.c b/main/gcc/ada/socket.c index 310de25029f..4a9e6ad7b44 100644 --- a/main/gcc/ada/socket.c +++ b/main/gcc/ada/socket.c @@ -37,39 +37,7 @@ #include "gsocket.h" -#if defined(VMS) -/* - * For VMS, gsocket.h can't include sockets-related DEC C header files - * when building the runtime (because these files are in a DEC C text library - * (DECC$RTLDEF.TLB) not accessible to GCC). So, we generate a separate header - * file along with s-oscons.ads and include it here. - */ -# include "s-oscons.h" - -/* - * We also need the declaration of struct hostent/servent, which s-oscons - * can't provide, so we copy it manually here. This needs to be kept in synch - * with the definition of that structure in the DEC C headers, which - * hopefully won't change frequently. - */ -typedef char *__netdb_char_ptr __attribute__ (( mode (SI) )); -typedef __netdb_char_ptr *__netdb_char_ptr_ptr __attribute__ (( mode (SI) )); - -struct hostent { - __netdb_char_ptr h_name; - __netdb_char_ptr_ptr h_aliases; - int h_addrtype; - int h_length; - __netdb_char_ptr_ptr h_addr_list; -}; - -struct servent { - __netdb_char_ptr s_name; - __netdb_char_ptr_ptr s_aliases; - int s_port; - __netdb_char_ptr s_proto; -}; -#elif defined(__FreeBSD__) +#if defined(__FreeBSD__) typedef unsigned int IOCTL_Req_T; #else typedef int IOCTL_Req_T; @@ -142,7 +110,7 @@ __gnat_disable_all_sigpipes (void) #endif } -#if defined (_WIN32) || defined (__vxworks) || defined (VMS) +#if defined (_WIN32) || defined (__vxworks) /* * Signalling FDs operations are implemented in Ada for these platforms * (see subunit GNAT.Sockets.Thin.Signalling_Fds). @@ -509,15 +477,6 @@ __gnat_get_h_errno (void) { return -1; } -#elif defined (VMS) - /* h_errno is defined as follows in OpenVMS' version of . - * However this header file is not available when building the GNAT - * runtime library using GCC, so we are hardcoding the definition - * directly. Note that the returned address is thread-specific. - */ - extern int *decc$h_errno_get_addr (); - return *decc$h_errno_get_addr (); - #elif defined (__rtems__) /* At this stage in the tool build, no networking .h files are available. * Newlib does not provide networking .h files and RTEMS is not built yet. @@ -550,11 +509,6 @@ __gnat_socket_ioctl (int fd, IOCTL_Req_T req, int *arg) { #ifndef HAVE_INET_PTON -#ifdef VMS -# define in_addr_t int -# define inet_addr decc$inet_addr -#endif - int __gnat_inet_pton (int af, const char *src, void *dst) { switch (af) { @@ -592,7 +546,7 @@ __gnat_inet_pton (int af, const char *src, void *dst) { } return (rc == 0); -#elif defined (__hpux__) || defined (VMS) +#elif defined (__hpux__) in_addr_t addr; int rc = -1; diff --git a/main/gcc/ada/sprint.adb b/main/gcc/ada/sprint.adb index 29526173db7..3eb4869f8f8 100644 --- a/main/gcc/ada/sprint.adb +++ b/main/gcc/ada/sprint.adb @@ -58,6 +58,10 @@ package body Sprint is -- requiring Sloc fixup, until Set_Debug_Sloc is called to set the proper -- value. The call clears it back to Empty. + First_Debug_Sloc : Source_Ptr; + -- Sloc of first byte of the current output file if we are generating a + -- source debug file. + Debug_Sloc : Source_Ptr; -- Sloc of first byte of line currently being written if we are -- generating a source debug file. @@ -512,7 +516,46 @@ package body Sprint is procedure Set_Debug_Sloc is begin if Debug_Generated_Code and then Present (Dump_Node) then - Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); + declare + Loc : constant Source_Ptr := Sloc (Dump_Node); + + begin + -- Do not change the location of nodes defined in package Standard + -- and nodes of pragmas scanned by Targparm. + + if Loc <= Standard_Location then + null; + + -- Update the location of a node which is part of the current .dg + -- output. This situation occurs in comma separated parameter + -- declarations since each parameter references the same parameter + -- type node (ie. obj1, obj2 : ). + + -- Note: This case is needed here since we cannot use the routine + -- In_Extended_Main_Code_Unit with nodes whose location is a .dg + -- file. + + elsif Loc >= First_Debug_Sloc then + Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); + + -- Do not change the location of nodes which are not part of the + -- generated code + + elsif not In_Extended_Main_Code_Unit (Loc) then + null; + + else + Set_Sloc (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); + end if; + end; + + -- We do not know the actual end location in the generated code and + -- it could be much closer than in the source code, so play safe. + + if Nkind_In (Dump_Node, N_Case_Statement, N_If_Statement) then + Set_End_Location (Dump_Node, Debug_Sloc + Source_Ptr (Column - 1)); + end if; + Dump_Node := Empty; end if; end Set_Debug_Sloc; @@ -573,6 +616,7 @@ package body Sprint is Debug_Flag_G := False; Debug_Flag_O := False; Debug_Flag_S := False; + First_Debug_Sloc := No_Location; -- Dump requested units @@ -590,6 +634,7 @@ package body Sprint is if Debug_Generated_Code then Set_Special_Output (Print_Debug_Line'Access); Create_Debug_Source (Source_Index (U), Debug_Sloc); + First_Debug_Sloc := Debug_Sloc; Write_Source_Line (1); Last_Line_Printed := 1; Sprint_Node (Cunit (U)); @@ -1350,10 +1395,55 @@ package body Sprint is Sprint_Node (Component_Definition (Node)); -- A contract node should not appear in the tree. It is a semantic - -- node attached to entry and [generic] subprogram entities. + -- node attached to entry and [generic] subprogram entities. But we + -- still provide meaningful output, in case called from the debugger. when N_Contract => - raise Program_Error; + declare + P : Node_Id; + + begin + Indent_Begin; + Write_Str ("N_Contract node"); + Write_Eol; + + Write_Indent_Str ("Pre_Post_Conditions"); + Indent_Begin; + + P := Pre_Post_Conditions (Node); + while Present (P) loop + Sprint_Node (P); + P := Next_Pragma (P); + end loop; + + Write_Eol; + Indent_End; + + Write_Indent_Str ("Contract_Test_Cases"); + Indent_Begin; + + P := Contract_Test_Cases (Node); + while Present (P) loop + Sprint_Node (P); + P := Next_Pragma (P); + end loop; + + Write_Eol; + Indent_End; + + Write_Indent_Str ("Classifications"); + Indent_Begin; + + P := Classifications (Node); + while Present (P) loop + Sprint_Node (P); + P := Next_Pragma (P); + end loop; + + Write_Eol; + Indent_End; + Indent_End; + end; when N_Decimal_Fixed_Point_Definition => Write_Str_With_Col_Check_Sloc (" delta "); @@ -2261,6 +2351,7 @@ package body Sprint is begin if Nkind (Odef) = N_Identifier + and then Present (Etype (Odef)) and then Is_Array_Type (Etype (Odef)) and then not Is_Constrained (Etype (Odef)) and then Present (Etype (Def_Id)) @@ -4083,7 +4174,7 @@ package body Sprint is -- Array types and string types - when E_Array_Type | E_String_Type => + when E_Array_Type => Write_Header; Write_Str ("array ("); diff --git a/main/gcc/ada/stand.adb b/main/gcc/ada/stand.adb index b2c6a3fa473..429f545a860 100644 --- a/main/gcc/ada/stand.adb +++ b/main/gcc/ada/stand.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/stand.ads b/main/gcc/ada/stand.ads index 6bcd8cbeb75..e93e9b4b89b 100644 --- a/main/gcc/ada/stand.ads +++ b/main/gcc/ada/stand.ads @@ -443,8 +443,7 @@ package Stand is -- Entity for universal real type. The bounds of this type correspond to -- to the largest supported real type (i.e. Long_Long_Float). It is the -- type used for runtime calculations in type universal real. Note that - -- this type is always IEEE format, even if Long_Long_Float is Vax_Float - -- (and in that case the bounds don't correspond exactly). + -- this type is always IEEE format. Universal_Fixed : Entity_Id; -- Entity for universal fixed type. This is a type with arbitrary diff --git a/main/gcc/ada/style.ads b/main/gcc/ada/style.ads index b52a8fb1227..525e5602b82 100644 --- a/main/gcc/ada/style.ads +++ b/main/gcc/ada/style.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,7 +79,7 @@ package Style is renames Style_Inst.Check_Apostrophe; -- Called after scanning an apostrophe to check spacing - procedure Check_Arrow + procedure Check_Arrow (Inside_Depends : Boolean := False) renames Style_Inst.Check_Arrow; -- Called after scanning out an arrow to check spacing @@ -180,7 +180,7 @@ package Style is -- procedure is called only if THEN appears at the start of a line with -- Token_Ptr pointing to the THEN keyword. - procedure Check_Unary_Plus_Or_Minus + procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) renames Style_Inst.Check_Unary_Plus_Or_Minus; -- Called after scanning a unary plus or minus to check spacing diff --git a/main/gcc/ada/styleg.adb b/main/gcc/ada/styleg.adb index c94759c7da0..a421f250285 100644 --- a/main/gcc/ada/styleg.adb +++ b/main/gcc/ada/styleg.adb @@ -126,13 +126,32 @@ package body Styleg is -- Check_Arrow -- ----------------- - -- In check tokens mode (-gnatys), arrow must be surrounded by spaces + -- In check tokens mode (-gnatys), arrow must be surrounded by spaces, + -- except that within the argument of a Depends macro the required format + -- is =>+ rather than => +). - procedure Check_Arrow is + procedure Check_Arrow (Inside_Depends : Boolean := False) is begin if Style_Check_Tokens then Require_Preceding_Space; - Require_Following_Space; + + if not Inside_Depends then + Require_Following_Space; + + -- Special handling for Inside_Depends + + else + if Source (Scan_Ptr) = ' ' + and then Source (Scan_Ptr + 1) = '+' + then + Error_Space_Not_Allowed (Scan_Ptr); + + elsif Source (Scan_Ptr) /= ' ' + and then Source (Scan_Ptr) /= '+' + then + Require_Following_Space; + end if; + end if; end if; end Check_Arrow; @@ -1032,10 +1051,17 @@ package body Styleg is -- In check token mode (-gnatyt), unary plus or minus must not be -- followed by a space. - procedure Check_Unary_Plus_Or_Minus is + -- Annoying exception: if we have the sequence =>+ within a Depends pragma + -- or aspect, then we insist on a space rather than forbidding it. + + procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) is begin if Style_Check_Tokens then - Check_No_Space_After; + if not Inside_Depends then + Check_No_Space_After; + else + Require_Following_Space; + end if; end if; end Check_Unary_Plus_Or_Minus; diff --git a/main/gcc/ada/styleg.ads b/main/gcc/ada/styleg.ads index 2369281b0f6..344d4fb7d91 100644 --- a/main/gcc/ada/styleg.ads +++ b/main/gcc/ada/styleg.ads @@ -2,11 +2,11 @@ -- -- -- GNAT COMPILER COMPONENTS -- -- -- --- S T Y L E G -- +-- S T Y L E G -- -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -52,8 +52,10 @@ package Styleg is procedure Check_Apostrophe; -- Called after scanning an apostrophe to check spacing - procedure Check_Arrow; - -- Called after scanning out an arrow to check spacing + procedure Check_Arrow (Inside_Depends : Boolean := False); + -- Called after scanning out an arrow to check spacing. Inside_Depends is + -- true if the call is from an argument of the Depends pragma (where the + -- allowed/required format is =>+). procedure Check_Attribute_Name (Reserved : Boolean); -- The current token is an attribute designator. Check that it @@ -143,8 +145,10 @@ package Styleg is -- would interfere with coverage testing). Handles case of THEN ABORT as -- an exception, as well as PRAGMA after ELSE. - procedure Check_Unary_Plus_Or_Minus; - -- Called after scanning a unary plus or minus to check spacing + procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False); + -- Called after scanning a unary plus or minus to check spacing. The flag + -- Inside_Depends is set if we are scanning within a Depends pragma or + -- Aspect, in which case =>+ requires a following space). procedure Check_Vertical_Bar; -- Called after scanning a vertical bar to check spacing diff --git a/main/gcc/ada/switch-b.adb b/main/gcc/ada/switch-b.adb index db6407abd72..880540eca3e 100644 --- a/main/gcc/ada/switch-b.adb +++ b/main/gcc/ada/switch-b.adb @@ -262,20 +262,6 @@ package body Switch.B is Ptr := Ptr + 1; Usage_Requested := True; - -- Processing for H switch - - when 'H' => - if Ptr = Max then - Bad_Switch (Switch_Chars); - end if; - - Ptr := Ptr + 1; - Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C); - - if Heap_Size /= 32 and then Heap_Size /= 64 then - Bad_Switch (Switch_Chars); - end if; - -- Processing for i switch when 'i' => diff --git a/main/gcc/ada/switch-c.adb b/main/gcc/ada/switch-c.adb index 04a6fa188f3..46939c6fd52 100644 --- a/main/gcc/ada/switch-c.adb +++ b/main/gcc/ada/switch-c.adb @@ -32,12 +32,15 @@ with Lib; use Lib; with Osint; use Osint; with Opt; use Opt; with Stylesw; use Stylesw; +with Targparm; use Targparm; with Ttypes; use Ttypes; with Validsw; use Validsw; with Warnsw; use Warnsw; with Ada.Unchecked_Deallocation; + with System.WCh_Con; use System.WCh_Con; +with System.OS_Lib; package body Switch.C is @@ -207,54 +210,70 @@ package body Switch.C is or else Switch_Chars (Ptr + 3) /= '=' then Osint.Fail ("missing path for --RTS"); + else - -- Check that this is the first time --RTS is specified or if - -- it is not the first time, the same path has been specified. + declare + Runtime_Dir : String_Access; - if RTS_Specified = null then - RTS_Specified := new String'(Switch_Chars (Ptr + 4 .. Max)); + begin + if System.OS_Lib.Is_Absolute_Path + (Switch_Chars (Ptr + 4 .. Max)) + then + Runtime_Dir := + new String' + (System.OS_Lib.Normalize_Pathname + (Switch_Chars (Ptr + 4 .. Max))); - elsif - RTS_Specified.all /= Switch_Chars (Ptr + 4 .. Max) - then - Osint.Fail ("--RTS cannot be specified multiple times"); - end if; + else + Runtime_Dir := + new String'(Switch_Chars (Ptr + 4 .. Max)); + end if; - -- Valid --RTS switch + -- Check that this is the first time --RTS is specified + -- or if it is not the first time, the same path has been + -- specified. - Opt.No_Stdinc := True; - Opt.RTS_Switch := True; + if RTS_Specified = null then + RTS_Specified := Runtime_Dir; - RTS_Src_Path_Name := - Get_RTS_Search_Dir - (Switch_Chars (Ptr + 4 .. Max), Include); + elsif RTS_Specified.all /= Runtime_Dir.all then + Osint.Fail ("--RTS cannot be specified multiple times"); + end if; - RTS_Lib_Path_Name := - Get_RTS_Search_Dir - (Switch_Chars (Ptr + 4 .. Max), Objects); + -- Valid --RTS switch - if RTS_Src_Path_Name /= null - and then RTS_Lib_Path_Name /= null - then - -- Store the -fRTS switch (Note: Store_Compilation_Switch - -- changes -fRTS back into --RTS for the actual output). + Opt.No_Stdinc := True; + Opt.RTS_Switch := True; - Store_Compilation_Switch (Switch_Chars); + RTS_Src_Path_Name := + Get_RTS_Search_Dir (Runtime_Dir.all, Include); - elsif RTS_Src_Path_Name = null - and then RTS_Lib_Path_Name = null - then - Osint.Fail ("RTS path not valid: missing " & - "adainclude and adalib directories"); + RTS_Lib_Path_Name := + Get_RTS_Search_Dir (Runtime_Dir.all, Objects); - elsif RTS_Src_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adainclude directory"); + if RTS_Src_Path_Name /= null + and then RTS_Lib_Path_Name /= null + then + -- Store the -fRTS switch (Note: Store_Compilation_Switch + -- changes -fRTS back into --RTS for the actual output). - elsif RTS_Lib_Path_Name = null then - Osint.Fail ("RTS path not valid: missing " & - "adalib directory"); - end if; + Store_Compilation_Switch (Switch_Chars); + + elsif RTS_Src_Path_Name = null + and then RTS_Lib_Path_Name = null + then + Osint.Fail ("RTS path not valid: missing " + & "adainclude and adalib directories"); + + elsif RTS_Src_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " + & "adainclude directory"); + + elsif RTS_Lib_Path_Name = null then + Osint.Fail ("RTS path not valid: missing " + & "adalib directory"); + end if; + end; end if; -- There are no other switches not starting with -gnat @@ -363,7 +382,7 @@ package body Switch.C is if C = 'b' and then (Ptr /= First_Ptr + 1 - or else not First_Switch) + or else not First_Switch) then Osint.Fail ("-gnatd.b must be first if combined " @@ -555,7 +574,7 @@ package body Switch.C is when 'F' => Ptr := Ptr + 1; - Check_Float_Overflow := True; + Check_Float_Overflow := not Machine_Overflows_On_Target; -- -gnateG (save preprocessor output) @@ -936,38 +955,57 @@ package body Switch.C is when 'o' => Ptr := Ptr + 1; - Suppress_Options.Suppress (Overflow_Check) := False; - -- Case of no digits after the -gnato + -- Case of -gnato0 (overflow checking turned off) + + if Ptr <= Max and then Switch_Chars (Ptr) = '0' then + Ptr := Ptr + 1; + Suppress_Options.Suppress (Overflow_Check) := True; + + -- We set strict mode in case overflow checking is turned + -- on locally (also records that we had a -gnato switch). - if Ptr > Max or else Switch_Chars (Ptr) not in '1' .. '3' then Suppress_Options.Overflow_Mode_General := Strict; Suppress_Options.Overflow_Mode_Assertions := Strict; - -- At least one digit after the -gnato + -- All cases other than -gnato0 (overflow checking turned on) else - -- Handle first digit after -gnato - - Suppress_Options.Overflow_Mode_General := - Get_Overflow_Mode (Switch_Chars (Ptr)); - Ptr := Ptr + 1; + Suppress_Options.Suppress (Overflow_Check) := False; - -- Only one digit after -gnato, set assertions mode to - -- be the same as general mode. + -- Case of no digits after the -gnato if Ptr > Max or else Switch_Chars (Ptr) not in '1' .. '3' then - Suppress_Options.Overflow_Mode_Assertions := - Suppress_Options.Overflow_Mode_General; + Suppress_Options.Overflow_Mode_General := Strict; + Suppress_Options.Overflow_Mode_Assertions := Strict; - -- Process second digit after -gnato + -- At least one digit after the -gnato else - Suppress_Options.Overflow_Mode_Assertions := + -- Handle first digit after -gnato + + Suppress_Options.Overflow_Mode_General := Get_Overflow_Mode (Switch_Chars (Ptr)); Ptr := Ptr + 1; + + -- Only one digit after -gnato, set assertions mode to be + -- the same as general mode. + + if Ptr > Max + or else Switch_Chars (Ptr) not in '1' .. '3' + then + Suppress_Options.Overflow_Mode_Assertions := + Suppress_Options.Overflow_Mode_General; + + -- Process second digit after -gnato + + else + Suppress_Options.Overflow_Mode_Assertions := + Get_Overflow_Mode (Switch_Chars (Ptr)); + Ptr := Ptr + 1; + end if; end if; end if; @@ -1009,6 +1047,13 @@ package body Switch.C is Validity_Checks_On := False; Opt.Suppress_Checks := True; + + -- Set overflow mode checking to strict in case it gets + -- turned on locally (also signals that overflow checking + -- has been specifically turned off). + + Suppress_Options.Overflow_Mode_General := Strict; + Suppress_Options.Overflow_Mode_Assertions := Strict; end if; -- -gnatP (periodic poll) diff --git a/main/gcc/ada/switch-m.adb b/main/gcc/ada/switch-m.adb index 575b1aad634..c52ca424788 100644 --- a/main/gcc/ada/switch-m.adb +++ b/main/gcc/ada/switch-m.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -790,6 +790,12 @@ package body Switch.M is elsif Switch_Chars = Makeutl.Single_Compile_Per_Obj_Dir_Switch then Opt.One_Compilation_Per_Obj_Dir := True; + elsif Switch_Chars = Makeutl.No_Exit_Message_Option then + Opt.No_Exit_Message := True; + + elsif Switch_Chars = Makeutl.Keep_Temp_Files_Option then + Opt.Keep_Temporary_Files := True; + elsif Switch_Chars (Ptr) = '-' then Bad_Switch (Switch_Chars); diff --git a/main/gcc/ada/symbols-processing-vms-alpha.adb b/main/gcc/ada/symbols-processing-vms-alpha.adb deleted file mode 100644 index c33739402c3..00000000000 --- a/main/gcc/ada/symbols-processing-vms-alpha.adb +++ /dev/null @@ -1,318 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S . P R O C E S S I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS Alpha version of this package - -separate (Symbols) -package body Processing is - - type Number is mod 2**16; - -- 16 bits unsigned number for number of characters - - EMH : constant Number := 8; - -- Code for the Module Header section - - GSD : constant Number := 10; - -- Code for the Global Symbol Definition section - - C_SYM : constant Number := 1; - -- Code for a Symbol subsection - - V_DEF_Mask : constant Number := 2 ** 1; - V_NORM_Mask : constant Number := 2 ** 6; - -- Comments ??? - - B : Byte; - - Number_Of_Characters : Natural := 0; - -- The number of characters of each section - - Native_Format : Boolean; - -- True if records are decoded by the system (like on VMS) - - Has_Pad : Boolean; - -- If true, a pad byte must be skipped before reading the next record - - -- The following variables are used by procedure Process when reading an - -- object file. - - Code : Number := 0; - Length : Natural := 0; - - Dummy : Number; - - Nchars : Natural := 0; - Flags : Number := 0; - - Symbol : String (1 .. 255); - LSymb : Natural; - - procedure Get (N : out Number); - -- Read two bytes from the object file LSB first as unsigned 16 bit number - - procedure Get (N : out Natural); - -- Read two bytes from the object file, LSByte first, as a Natural - - --------- - -- Get -- - --------- - - procedure Get (N : out Number) is - C : Byte; - LSByte : Number; - begin - Read (File, C); - LSByte := Byte'Pos (C); - Read (File, C); - N := LSByte + (256 * Byte'Pos (C)); - end Get; - - procedure Get (N : out Natural) is - Result : Number; - begin - Get (Result); - N := Natural (Result); - end Get; - - ------------- - -- Process -- - ------------- - - procedure Process - (Object_File : String; - Success : out Boolean) - is - OK : Boolean := True; - - begin - -- Open the object file with Byte_IO. Return with Success = False if - -- this fails. - - begin - Open (File, In_File, Object_File); - exception - when others => - Put_Line - ("*** Unable to open object file """ & Object_File & """"); - Success := False; - return; - end; - - -- Assume that the object file has a correct format - - Success := True; - - -- Check the file format in case of cross-tool - - Get (Code); - Get (Number_Of_Characters); - Get (Dummy); - - if Code = Dummy and then Number_Of_Characters = Natural (EMH) then - - -- Looks like a cross tool - - Native_Format := False; - Number_Of_Characters := Natural (Dummy) - 4; - Has_Pad := (Number_Of_Characters mod 2) = 1; - - elsif Code = EMH then - Native_Format := True; - Number_Of_Characters := Number_Of_Characters - 6; - Has_Pad := False; - - else - Put_Line ("file """ & Object_File & """ is not an object file"); - Close (File); - Success := False; - return; - end if; - - -- Skip the EMH section - - for J in 1 .. Number_Of_Characters loop - Read (File, B); - end loop; - - -- Get the different sections one by one from the object file - - while not End_Of_File (File) loop - - if not Native_Format then - - -- Skip pad byte if present - - if Has_Pad then - Get (B); - end if; - - -- Skip record length - - Get (Dummy); - end if; - - Get (Code); - Get (Number_Of_Characters); - - if not Native_Format then - if Natural (Dummy) /= Number_Of_Characters then - - -- Format error - - raise Constraint_Error; - end if; - - Has_Pad := (Number_Of_Characters mod 2) = 1; - end if; - - -- The header is 4 bytes length - - Number_Of_Characters := Number_Of_Characters - 4; - - -- If this is not a Global Symbol Definition section, skip to the - -- next section. - - if Code /= GSD then - for J in 1 .. Number_Of_Characters loop - Read (File, B); - end loop; - - else - -- Skip over the next 4 bytes - - Get (Dummy); - Get (Dummy); - Number_Of_Characters := Number_Of_Characters - 4; - - -- Get each subsection in turn - - loop - Get (Code); - Get (Nchars); - Get (Dummy); - Get (Flags); - Number_Of_Characters := Number_Of_Characters - 8; - Nchars := Nchars - 8; - - -- If this is a symbol and the V_DEF flag is set, get symbol - - if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then - - -- First, reach the symbol length - - for J in 1 .. 25 loop - Read (File, B); - Nchars := Nchars - 1; - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - - Length := Byte'Pos (B); - LSymb := 0; - - -- Get the symbol characters - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - - if Length > 0 then - LSymb := LSymb + 1; - Symbol (LSymb) := B; - Length := Length - 1; - end if; - end loop; - - -- Check if it is a symbol from a generic body - - OK := True; - - for J in 1 .. LSymb - 2 loop - if Symbol (J) = 'G' and then Symbol (J + 1) = 'P' - and then Symbol (J + 2) in '0' .. '9' - then - OK := False; - exit; - end if; - end loop; - - if OK then - - -- Create the new Symbol - - declare - S_Data : Symbol_Data; - - begin - S_Data.Name := new String'(Symbol (1 .. LSymb)); - - -- The symbol kind (Data or Procedure) depends on the - -- V_NORM flag. - - if (Flags and V_NORM_Mask) = 0 then - S_Data.Kind := Data; - else - S_Data.Kind := Proc; - end if; - - -- Put the new symbol in the table - - Symbol_Table.Append (Complete_Symbols, S_Data); - end; - end if; - - else - -- As it is not a symbol subsection, skip to the next - -- subsection. - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - end if; - - -- Exit the GSD section when number of characters reaches zero - - exit when Number_Of_Characters = 0; - end loop; - end if; - end loop; - - -- The object file has been processed, close it - - Close (File); - - exception - -- For any exception, output an error message, close the object file - -- and return with Success = False. - - when X : others => - Put_Line ("unexpected exception raised while processing """ - & Object_File & """"); - Put_Line (Exception_Information (X)); - Close (File); - Success := False; - end Process; - -end Processing; diff --git a/main/gcc/ada/symbols-processing-vms-ia64.adb b/main/gcc/ada/symbols-processing-vms-ia64.adb deleted file mode 100644 index beb099e40b0..00000000000 --- a/main/gcc/ada/symbols-processing-vms-ia64.adb +++ /dev/null @@ -1,430 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S . P R O C E S S I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS/IA64 version of this package - -with Ada.IO_Exceptions; - -with Ada.Unchecked_Deallocation; - -separate (Symbols) -package body Processing is - - type String_Array is array (Positive range <>) of String_Access; - type Strings_Ptr is access String_Array; - - procedure Free is - new Ada.Unchecked_Deallocation (String_Array, Strings_Ptr); - - type Section_Header is record - Shname : Integer; - Shtype : Integer; - Shoffset : Integer; - Shsize : Integer; - Shlink : Integer; - end record; - - type Section_Header_Array is array (Natural range <>) of Section_Header; - type Section_Header_Ptr is access Section_Header_Array; - - procedure Free is - new Ada.Unchecked_Deallocation (Section_Header_Array, Section_Header_Ptr); - - ------------- - -- Process -- - ------------- - - procedure Process - (Object_File : String; - Success : out Boolean) - is - B : Byte; - W : Integer; - - Str : String (1 .. 1000) := (others => ' '); - Str_Last : Natural; - - Strings : Strings_Ptr; - - Shoff : Integer; - Shnum : Integer; - Shentsize : Integer; - - Shname : Integer; - Shtype : Integer; - Shoffset : Integer; - Shsize : Integer; - Shlink : Integer; - - Symtab_Index : Natural := 0; - String_Table_Index : Natural := 0; - - End_Symtab : Integer; - - Stname : Integer; - Stinfo : Character; - Stother : Character; - Sttype : Integer; - Stbind : Integer; - Stshndx : Integer; - Stvis : Integer; - - STV_Internal : constant := 1; - STV_Hidden : constant := 2; - - Section_Headers : Section_Header_Ptr; - - Offset : Natural := 0; - OK : Boolean := True; - - procedure Get_Byte (B : out Byte); - -- Read one byte from the object file - - procedure Get_Half (H : out Integer); - -- Read one half work from the object file - - procedure Get_Word (W : out Integer); - -- Read one full word from the object file - - procedure Reset; - -- Restart reading the object file - - procedure Skip_Half; - -- Read and disregard one half word from the object file - - -------------- - -- Get_Byte -- - -------------- - - procedure Get_Byte (B : out Byte) is - begin - Byte_IO.Read (File, B); - Offset := Offset + 1; - end Get_Byte; - - -------------- - -- Get_Half -- - -------------- - - procedure Get_Half (H : out Integer) is - C1, C2 : Character; - begin - Get_Byte (C1); Get_Byte (C2); - H := - Integer'(Character'Pos (C2)) * 256 + Integer'(Character'Pos (C1)); - end Get_Half; - - -------------- - -- Get_Word -- - -------------- - - procedure Get_Word (W : out Integer) is - H1, H2 : Integer; - begin - Get_Half (H1); Get_Half (H2); - W := H2 * 256 * 256 + H1; - end Get_Word; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - Offset := 0; - Byte_IO.Reset (File); - end Reset; - - --------------- - -- Skip_Half -- - --------------- - - procedure Skip_Half is - B : Byte; - pragma Unreferenced (B); - begin - Byte_IO.Read (File, B); - Byte_IO.Read (File, B); - Offset := Offset + 2; - end Skip_Half; - - -- Start of processing for Process - - begin - -- Open the object file with Byte_IO. Return with Success = False if - -- this fails. - - begin - Open (File, In_File, Object_File); - exception - when others => - Put_Line - ("*** Unable to open object file """ & Object_File & """"); - Success := False; - return; - end; - - -- Assume that the object file has a correct format - - Success := True; - - -- Skip ELF identification - - while Offset < 16 loop - Get_Byte (B); - end loop; - - -- Skip e_type - - Skip_Half; - - -- Skip e_machine - - Skip_Half; - - -- Skip e_version - - Get_Word (W); - - -- Skip e_entry - - for J in 1 .. 8 loop - Get_Byte (B); - end loop; - - -- Skip e_phoff - - for J in 1 .. 8 loop - Get_Byte (B); - end loop; - - Get_Word (Shoff); - - -- Skip upper half of Shoff - - for J in 1 .. 4 loop - Get_Byte (B); - end loop; - - -- Skip e_flags - - Get_Word (W); - - -- Skip e_ehsize - - Skip_Half; - - -- Skip e_phentsize - - Skip_Half; - - -- Skip e_phnum - - Skip_Half; - - Get_Half (Shentsize); - - Get_Half (Shnum); - - Section_Headers := new Section_Header_Array (0 .. Shnum - 1); - - -- Go to Section Headers - - while Offset < Shoff loop - Get_Byte (B); - end loop; - - -- Reset Symtab_Index - - Symtab_Index := 0; - - for J in Section_Headers'Range loop - - -- Get the data for each Section Header - - Get_Word (Shname); - Get_Word (Shtype); - - for K in 1 .. 16 loop - Get_Byte (B); - end loop; - - Get_Word (Shoffset); - Get_Word (W); - - Get_Word (Shsize); - Get_Word (W); - - Get_Word (Shlink); - - while (Offset - Shoff) mod Shentsize /= 0 loop - Get_Byte (B); - end loop; - - -- If this is the Symbol Table Section Header, record its index - - if Shtype = 2 then - Symtab_Index := J; - end if; - - Section_Headers (J) := (Shname, Shtype, Shoffset, Shsize, Shlink); - end loop; - - if Symtab_Index = 0 then - Success := False; - return; - end if; - - End_Symtab := - Section_Headers (Symtab_Index).Shoffset + - Section_Headers (Symtab_Index).Shsize; - - String_Table_Index := Section_Headers (Symtab_Index).Shlink; - Strings := - new String_Array (1 .. Section_Headers (String_Table_Index).Shsize); - - -- Go get the String Table section for the Symbol Table - - Reset; - - while Offset < Section_Headers (String_Table_Index).Shoffset loop - Get_Byte (B); - end loop; - - Offset := 0; - - Get_Byte (B); -- zero - - while Offset < Section_Headers (String_Table_Index).Shsize loop - Str_Last := 0; - - loop - Get_Byte (B); - if B /= ASCII.NUL then - Str_Last := Str_Last + 1; - Str (Str_Last) := B; - - else - Strings (Offset - Str_Last - 1) := - new String'(Str (1 .. Str_Last)); - exit; - end if; - end loop; - end loop; - - -- Go get the Symbol Table - - Reset; - - while Offset < Section_Headers (Symtab_Index).Shoffset loop - Get_Byte (B); - end loop; - - while Offset < End_Symtab loop - Get_Word (Stname); - Get_Byte (Stinfo); - Get_Byte (Stother); - Get_Half (Stshndx); - for J in 1 .. 4 loop - Get_Word (W); - end loop; - - Sttype := Integer'(Character'Pos (Stinfo)) mod 16; - Stbind := Integer'(Character'Pos (Stinfo)) / 16; - Stvis := Integer'(Character'Pos (Stother)) mod 4; - - if (Sttype = 1 or else Sttype = 2) - and then Stbind /= 0 - and then Stshndx /= 0 - and then Stvis /= STV_Internal - and then Stvis /= STV_Hidden - then - -- Check if this is a symbol from a generic body - - OK := True; - - for J in Strings (Stname)'First .. Strings (Stname)'Last - 2 loop - if Strings (Stname) (J) = 'G' - and then Strings (Stname) (J + 1) = 'P' - and then Strings (Stname) (J + 2) in '0' .. '9' - then - OK := False; - exit; - end if; - end loop; - - if OK then - declare - S_Data : Symbol_Data; - begin - S_Data.Name := new String'(Strings (Stname).all); - - if Sttype = 1 then - S_Data.Kind := Data; - - else - S_Data.Kind := Proc; - end if; - - -- Put the new symbol in the table - - Symbol_Table.Append (Complete_Symbols, S_Data); - end; - end if; - end if; - end loop; - - -- The object file has been processed, close it - - Close (File); - - -- Free the allocated memory - - Free (Section_Headers); - - for J in Strings'Range loop - if Strings (J) /= null then - Free (Strings (J)); - end if; - end loop; - - Free (Strings); - - exception - -- For any exception, output an error message, close the object file - -- and return with Success = False. - - when Ada.IO_Exceptions.End_Error => - Close (File); - - when X : others => - Put_Line ("unexpected exception raised while processing """ - & Object_File & """"); - Put_Line (Exception_Information (X)); - Close (File); - Success := False; - end Process; - -end Processing; diff --git a/main/gcc/ada/symbols-vms.adb b/main/gcc/ada/symbols-vms.adb deleted file mode 100644 index 39c9beb3202..00000000000 --- a/main/gcc/ada/symbols-vms.adb +++ /dev/null @@ -1,637 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version of this package - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Sequential_IO; -with Ada.Text_IO; use Ada.Text_IO; - -package body Symbols is - - Case_Sensitive : constant String := "case_sensitive="; - Symbol_Vector : constant String := "SYMBOL_VECTOR=("; - Equal_Data : constant String := "=DATA)"; - Equal_Procedure : constant String := "=PROCEDURE)"; - Gsmatch : constant String := "gsmatch="; - Gsmatch_Lequal : constant String := "gsmatch=lequal,"; - - Symbol_File_Name : String_Access := null; - -- Name of the symbol file - - Long_Symbol_Length : constant := 100; - -- Magic length of symbols, over which the lines are split - - Sym_Policy : Policy := Autonomous; - -- The symbol policy. Set by Initialize - - Major_ID : Integer := 1; - -- The Major ID. May be modified by Initialize if Library_Version is - -- specified or if it is read from the reference symbol file. - - Soft_Major_ID : Boolean := True; - -- False if library version is specified in procedure Initialize. - -- When True, Major_ID may be modified if found in the reference symbol - -- file. - - Minor_ID : Natural := 0; - -- The Minor ID. May be modified if read from the reference symbol file - - Soft_Minor_ID : Boolean := True; - -- False if symbol policy is Autonomous, if library version is specified - -- in procedure Initialize and is not the same as the major ID read from - -- the reference symbol file. When True, Minor_ID may be increased in - -- Compliant symbol policy. - - subtype Byte is Character; - -- Object files are stream of bytes, but some of these bytes, those for - -- the names of the symbols, are ASCII characters. - - package Byte_IO is new Ada.Sequential_IO (Byte); - use Byte_IO; - - File : Byte_IO.File_Type; - -- Each object file is read as a stream of bytes (characters) - - function Equal (Left, Right : Symbol_Data) return Boolean; - -- Test for equality of symbols - - function Image (N : Integer) return String; - -- Returns the image of N, without the initial space - - ----------- - -- Equal -- - ----------- - - function Equal (Left, Right : Symbol_Data) return Boolean is - begin - return Left.Name /= null and then - Right.Name /= null and then - Left.Name.all = Right.Name.all and then - Left.Kind = Right.Kind and then - Left.Present = Right.Present; - end Equal; - - ----------- - -- Image -- - ----------- - - function Image (N : Integer) return String is - Result : constant String := N'Img; - begin - if Result (Result'First) = ' ' then - return Result (Result'First + 1 .. Result'Last); - else - return Result; - end if; - end Image; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (Symbol_File : String; - Reference : String; - Symbol_Policy : Policy; - Quiet : Boolean; - Version : String; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - Line : String (1 .. 2_000); - Last : Natural; - - Offset : Natural; - - begin - -- Record the symbol file name - - Symbol_File_Name := new String'(Symbol_File); - - -- Record the policy - - Sym_Policy := Symbol_Policy; - - -- Record the version (Major ID) - - if Version = "" then - Major_ID := 1; - Soft_Major_ID := True; - - else - begin - Major_ID := Integer'Value (Version); - Soft_Major_ID := False; - - if Major_ID <= 0 then - raise Constraint_Error; - end if; - - exception - when Constraint_Error => - if not Quiet then - Put_Line ("Version """ & Version & """ is illegal."); - Put_Line ("On VMS, version must be a positive number"); - end if; - - Success := False; - return; - end; - end if; - - Minor_ID := 0; - Soft_Minor_ID := Sym_Policy /= Autonomous; - - -- Empty the symbol tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Assume that everything will be fine - - Success := True; - - -- If policy is Compliant or Controlled, attempt to read the reference - -- file. If policy is Restricted, attempt to read the symbol file. - - if Sym_Policy /= Autonomous then - case Sym_Policy is - when Autonomous | Direct => - null; - - when Compliant | Controlled => - begin - Open (File, In_File, Reference); - - exception - when Ada.Text_IO.Name_Error => - Success := False; - return; - - when X : others => - if not Quiet then - Put_Line ("could not open """ & Reference & """"); - Put_Line (Exception_Message (X)); - end if; - - Success := False; - return; - end; - - when Restricted => - begin - Open (File, In_File, Symbol_File); - - exception - when Ada.Text_IO.Name_Error => - Success := False; - return; - - when X : others => - if not Quiet then - Put_Line ("could not open """ & Symbol_File & """"); - Put_Line (Exception_Message (X)); - end if; - - Success := False; - return; - end; - end case; - - -- Read line by line - - while not End_Of_File (File) loop - Offset := 0; - loop - Get_Line (File, Line (Offset + 1 .. Line'Last), Last); - exit when Line (Last) /= '-'; - - if End_Of_File (File) then - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted:"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - - else - Offset := Last - 1; - end if; - end loop; - - -- Ignore empty lines - - if Last = 0 then - null; - - -- Ignore lines starting with "case_sensitive=" - - elsif Last > Case_Sensitive'Length - and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive - then - null; - - -- Line starting with "SYMBOL_VECTOR=(" - - elsif Last > Symbol_Vector'Length - and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector - then - - -- SYMBOL_VECTOR=(=DATA) - - if Last > Symbol_Vector'Length + Equal_Data'Length and then - Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data - then - Symbol_Table.Append (Original_Symbols, - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Data'Length)), - Kind => Data, - Present => True)); - - -- SYMBOL_VECTOR=(=PROCEDURE) - - elsif Last > Symbol_Vector'Length + Equal_Procedure'Length - and then - Line (Last - Equal_Procedure'Length + 1 .. Last) = - Equal_Procedure - then - Symbol_Table.Append (Original_Symbols, - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Procedure'Length)), - Kind => Proc, - Present => True)); - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted:"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - - -- Lines with "gsmatch=lequal," or "gsmatch=equal," - - elsif Last > Gsmatch'Length - and then Line (1 .. Gsmatch'Length) = Gsmatch - then - declare - Start : Positive := Gsmatch'Length + 1; - Finish : Positive := Start; - OK : Boolean := True; - ID : Integer; - - begin - -- First, look for the first coma - - loop - if Start >= Last - 1 then - OK := False; - exit; - - elsif Line (Start) = ',' then - Start := Start + 1; - exit; - - else - Start := Start + 1; - end if; - end loop; - - Finish := Start; - - -- If the comma is found, get the Major and the Minor IDs - - if OK then - loop - if Line (Finish) not in '0' .. '9' - or else Finish >= Last - 1 - then - OK := False; - exit; - end if; - - exit when Line (Finish + 1) = ','; - - Finish := Finish + 1; - end loop; - end if; - - if OK then - ID := Integer'Value (Line (Start .. Finish)); - OK := ID /= 0; - - -- If Soft_Major_ID is True, it means that - -- Library_Version was not specified. - - if Soft_Major_ID then - Major_ID := ID; - - -- If the Major ID in the reference file is different - -- from the Library_Version, then the Minor ID will be 0 - -- because there is no point in taking the Minor ID in - -- the reference file, or incrementing it. So, we set - -- Soft_Minor_ID to False, so that we don't modify - -- the Minor_ID later. - - elsif Major_ID /= ID then - Soft_Minor_ID := False; - end if; - - Start := Finish + 2; - Finish := Start; - - loop - if Line (Finish) not in '0' .. '9' then - OK := False; - exit; - end if; - - exit when Finish = Last; - - Finish := Finish + 1; - end loop; - - -- Only set Minor_ID if Soft_Minor_ID is True (see above) - - if OK and then Soft_Minor_ID then - Minor_ID := Integer'Value (Line (Start .. Finish)); - end if; - end if; - - -- If OK is not True, that means the line is not correctly - -- formatted. - - if not OK then - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end; - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("unexpected line in symbol file """ & - Reference & """"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end loop; - - Close (File); - end if; - end Initialize; - - ---------------- - -- Processing -- - ---------------- - - package body Processing is separate; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize - (Quiet : Boolean; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - -- The symbol file - - S_Data : Symbol_Data; - -- A symbol - - Cur : Positive := 1; - -- Most probable index in the Complete_Symbols of the current symbol - -- in Original_Symbol. - - Found : Boolean; - - begin - -- Nothing to be done if Initialize has never been called - - if Symbol_File_Name = null then - Success := False; - - else - - -- First find if the symbols in the reference symbol file are also - -- in the object files. Note that this is not done if the policy is - -- Autonomous, because no reference symbol file has been read. - - -- Expect the first symbol in the symbol file to also be the first - -- in Complete_Symbols. - - Cur := 1; - - for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop - S_Data := Original_Symbols.Table (Index_1); - Found := False; - - First_Object_Loop : - for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit First_Object_Loop; - end if; - end loop First_Object_Loop; - - -- If the symbol could not be found between Cur and Last, try - -- before Cur. - - if not Found then - Second_Object_Loop : - for Index_2 in 1 .. Cur - 1 loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit Second_Object_Loop; - end if; - end loop Second_Object_Loop; - end if; - - -- If the symbol is not found, mark it as such in the table - - if not Found then - if (not Quiet) or else Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is no longer present in the object files"); - end if; - - if Sym_Policy = Controlled or else Sym_Policy = Restricted then - Success := False; - return; - - -- Any symbol that is undefined in the reference symbol file - -- triggers an increase of the Major ID, because the new - -- version of the library is no longer compatible with - -- existing executables. - - elsif Soft_Major_ID then - Major_ID := Major_ID + 1; - Minor_ID := 0; - Soft_Major_ID := False; - Soft_Minor_ID := False; - end if; - - Original_Symbols.Table (Index_1).Present := False; - Free (Original_Symbols.Table (Index_1).Name); - - if Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - end if; - end loop; - - if Sym_Policy /= Restricted then - - -- Append additional symbols, if any, to the Original_Symbols - -- table. - - for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop - S_Data := Complete_Symbols.Table (Index); - - if S_Data.Present then - - if Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is not in the reference symbol file"); - Success := False; - return; - - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - - Symbol_Table.Append (Original_Symbols, S_Data); - Complete_Symbols.Table (Index).Present := False; - end if; - end loop; - - -- Create the symbol file - - Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); - - Put (File, Case_Sensitive); - Put_Line (File, "yes"); - - -- Put a line in the symbol file for each symbol in symbol table - - for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop - if Original_Symbols.Table (Index).Present then - Put (File, Symbol_Vector); - - -- Split the line if symbol name length is too large - - if Original_Symbols.Table (Index).Name'Length > - Long_Symbol_Length - then - Put_Line (File, "-"); - end if; - - Put (File, Original_Symbols.Table (Index).Name.all); - - if Original_Symbols.Table (Index).Name'Length > - Long_Symbol_Length - then - Put_Line (File, "-"); - end if; - - if Original_Symbols.Table (Index).Kind = Data then - Put_Line (File, Equal_Data); - - else - Put_Line (File, Equal_Procedure); - end if; - - Free (Original_Symbols.Table (Index).Name); - end if; - end loop; - - Put (File, Case_Sensitive); - Put_Line (File, "NO"); - - -- Put the version IDs - - Put (File, Gsmatch_Lequal); - Put (File, Image (Major_ID)); - Put (File, ','); - Put_Line (File, Image (Minor_ID)); - - -- And we are done - - Close (File); - - -- Reset both tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Clear the symbol file name - - Free (Symbol_File_Name); - end if; - - Success := True; - end if; - - exception - when X : others => - Put_Line ("unexpected exception raised while finalizing """ - & Symbol_File_Name.all & """"); - Put_Line (Exception_Information (X)); - Success := False; - end Finalize; - -end Symbols; diff --git a/main/gcc/ada/symbols.ads b/main/gcc/ada/symbols.ads index 65954dc8b76..a1d24576839 100644 --- a/main/gcc/ada/symbols.ads +++ b/main/gcc/ada/symbols.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 +91,9 @@ package Symbols is package Processing is - -- This package, containing a single visible procedure Process, exists so - -- that it can be a subunits, for some platforms (such as VMS Alpha and - -- IA64), the body of package Symbols is common, while the subunit - -- Processing is not. + -- This package, containing a single visible procedure Process, exists + -- so that it can be a subunits, for some platforms, the body of package + -- Symbols is common, while the subunit Processing is not. procedure Process (Object_File : String; diff --git a/main/gcc/ada/sysdep.c b/main/gcc/ada/sysdep.c index 207ef60919e..3008c787430 100644 --- a/main/gcc/ada/sysdep.c +++ b/main/gcc/ada/sysdep.c @@ -42,6 +42,7 @@ #endif #include "selectLib.h" #include "vxWorks.h" +#include "version.h" #if defined (__RTP__) # include "vwModNum.h" #endif /* __RTP__ */ @@ -949,7 +950,7 @@ __gnat_is_file_not_found_error (int errno_val) { /* In the case of VxWorks, we also have to take into account various * filesystem-specific variants of this error. */ -#if ! defined (VTHREADS) +#if ! defined (VTHREADS) && (_WRS_VXWORKS_MAJOR < 7) case S_dosFsLib_FILE_NOT_FOUND: #endif #if ! defined (__RTP__) && (! defined (VTHREADS) || defined (__VXWORKSMILS__)) diff --git a/main/gcc/ada/system-vms-ia64.ads b/main/gcc/ada/system-vms-ia64.ads deleted file mode 100644 index 0b7f9475150..00000000000 --- a/main/gcc/ada/system-vms-ia64.ads +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 1992-2013, 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 -- --- . -- --- -- --- 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). - - 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 new Long_Integer; - Null_Address : constant Address; - -- Although this is declared as an integer type, no arithmetic operations - -- are available (see abstract declarations below), and furthermore there - -- is special processing in the compiler that prevents the use of integer - -- literals with this type (use To_Address to convert integer literals). - -- - -- Conversion to and from Short_Address is however freely permitted, and - -- is indeed the reason that Address is declared as an integer type. - - 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, "="); - - -- Abstract declarations for arithmetic operations on type address. - -- These declarations are needed when Address is non-private. They - -- avoid excessive visibility of arithmetic operations on address - -- which are typically available elsewhere (e.g. Storage_Elements) - -- and which would cause excessive ambiguities in application code. - - function "+" (Left, Right : Address) return Address is abstract; - function "-" (Left, Right : Address) return Address is abstract; - function "/" (Left, Right : Address) return Address is abstract; - function "*" (Left, Right : Address) return Address is abstract; - function "mod" (Left, Right : Address) return Address is abstract; - - -- 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 - - 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; - OpenVMS : constant Boolean := True; - VAX_Float : constant Boolean := False; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - 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; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : 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. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- 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 with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - 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 => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (Cond_Value : Integer); - pragma Import (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove. - - pragma Ident ("GNAT"); -- Gnat_Static_Version_String - -- Default ident for all VMS images. - -end System; diff --git a/main/gcc/ada/system-vms_64.ads b/main/gcc/ada/system-vms_64.ads deleted file mode 100644 index cc03c165968..00000000000 --- a/main/gcc/ada/system-vms_64.ads +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 1992-2013, 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 -- --- . -- --- -- --- 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). - - 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 new Long_Integer; - Null_Address : constant Address; - -- Although this is declared as an integer type, no arithmetic operations - -- are available (see abstract declarations below), and furthermore there - -- is special processing in the compiler that prevents the use of integer - -- literals with this type (use To_Address to convert integer literals). - -- - -- Conversion to and from Short_Address is however freely permitted, and - -- is indeed the reason that Address is declared as an integer type. - - 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, "="); - - -- Abstract declarations for arithmetic operations on type address. - -- These declarations are needed when Address is non-private. They - -- avoid excessive visibility of arithmetic operations on address - -- which are typically available elsewhere (e.g. Storage_Elements) - -- and which would cause excessive ambiguities in application code. - - function "+" (Left, Right : Address) return Address is abstract; - function "-" (Left, Right : Address) return Address is abstract; - function "/" (Left, Right : Address) return Address is abstract; - function "*" (Left, Right : Address) return Address is abstract; - function "mod" (Left, Right : Address) return Address is abstract; - - -- 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 - - 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 := False; - 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; - OpenVMS : constant Boolean := True; - VAX_Float : constant Boolean := False; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - 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; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : 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. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- 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 with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - 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 => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (Cond_Value : Integer); - pragma Import (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove. - - pragma Ident ("GNAT"); -- Gnat_Static_Version_String - -- Default ident for all VMS images. - -end System; diff --git a/main/gcc/ada/system-vxworks-arm.ads b/main/gcc/ada/system-vxworks-arm.ads index e7418a8a58a..3b455d29ffc 100644 --- a/main/gcc/ada/system-vxworks-arm.ads +++ b/main/gcc/ada/system-vxworks-arm.ads @@ -115,6 +115,10 @@ package System is private + pragma Linker_Options ("--specs=vxworks-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + type Address is mod Memory_Size; Null_Address : constant Address := 0; @@ -151,6 +155,6 @@ private Always_Compatible_Rep : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; end System; diff --git a/main/gcc/ada/system-vxworks-ppc.ads b/main/gcc/ada/system-vxworks-ppc.ads index 62d604f6319..94615777a0e 100644 --- a/main/gcc/ada/system-vxworks-ppc.ads +++ b/main/gcc/ada/system-vxworks-ppc.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (VxWorks 5 Version PPC) -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- @@ -115,14 +115,12 @@ package System is private - -- Note: we now more closely rely on the VxWorks mechanisms to register - -- exception tables for ZCX support in kernel mode, thanks to crt objects - -- featuring dedicated constructors triggered by linker options below. + pragma Linker_Options ("--specs=vxworks-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. - -- Commenting the pragma for the sjlj runtimes is performed automatically - -- by our Makefiles, so this line needs to be manipulated with care. - - pragma Linker_Options ("-crtbe" & ASCII.NUL & "-auto-register"); + pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); + -- Setup proper set of -L's for this configuration type Address is mod Memory_Size; Null_Address : constant Address := 0; diff --git a/main/gcc/ada/system.ads b/main/gcc/ada/system.ads index 7f6f13b1a1e..9206c1f685d 100644 --- a/main/gcc/ada/system.ads +++ b/main/gcc/ada/system.ads @@ -7,7 +7,7 @@ -- S p e c -- -- (Compiler Version) -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, 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 -- @@ -148,7 +148,6 @@ private Frontend_Layout : constant Boolean := False; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := False; Preallocated_Stacks : constant Boolean := False; Signed_Zeros : constant Boolean := True; Stack_Check_Default : constant Boolean := False; diff --git a/main/gcc/ada/targparm.adb b/main/gcc/ada/targparm.adb index 0f93344ef37..8824f4fc2ef 100644 --- a/main/gcc/ada/targparm.adb +++ b/main/gcc/ada/targparm.adb @@ -55,7 +55,6 @@ package body Targparm is MOV, -- Machine_Overflows MRN, -- Machine_Rounds PAS, -- Preallocated_Stacks - RTX, -- RTX_RTSS_Kernel_Module SAG, -- Support_Aggregates SAP, -- Support_Atomic_Primitives SCA, -- Support_Composite_Assign @@ -67,8 +66,6 @@ package body Targparm is SNZ, -- Signed_Zeros SSL, -- Suppress_Standard_Library UAM, -- Use_Ada_Main_Program_Name - VMS, -- OpenVMS - VXF, -- VAX Float ZCD); -- ZCX_By_Default Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False); @@ -93,7 +90,6 @@ package body Targparm is MOV_Str : aliased constant Source_Buffer := "Machine_Overflows"; MRN_Str : aliased constant Source_Buffer := "Machine_Rounds"; PAS_Str : aliased constant Source_Buffer := "Preallocated_Stacks"; - RTX_Str : aliased constant Source_Buffer := "RTX_RTSS_Kernel_Module"; SAG_Str : aliased constant Source_Buffer := "Support_Aggregates"; SAP_Str : aliased constant Source_Buffer := "Support_Atomic_Primitives"; SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign"; @@ -105,8 +101,6 @@ package body Targparm is SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros"; SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library"; UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name"; - VMS_Str : aliased constant Source_Buffer := "OpenVMS"; - VXF_Str : aliased constant Source_Buffer := "VAX_Float"; ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default"; -- The following defines a set of pointers to the above strings, @@ -131,7 +125,6 @@ package body Targparm is MOV_Str'Access, MRN_Str'Access, PAS_Str'Access, - RTX_Str'Access, SAG_Str'Access, SAP_Str'Access, SCA_Str'Access, @@ -143,8 +136,6 @@ package body Targparm is SNZ_Str'Access, SSL_Str'Access, UAM_Str'Access, - VMS_Str'Access, - VXF_Str'Access, ZCD_Str'Access); ----------------------- @@ -221,6 +212,16 @@ package body Targparm is Opt.Address_Is_Private := False; + -- Loop through source lines + + -- Note: in the case or pragmas, we are only interested in pragmas that + -- appear as configuration pragmas. These are left justified, so they + -- do not have three spaces at the start. Pragmas appearing within the + -- package (like Pure and No_Elaboration_Code_All) will have the three + -- spaces at the start and so will be ignored. + + -- For a special exception, see processing for pragma Pure below + P := Source_First; Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop @@ -470,12 +471,6 @@ package body Targparm is Opt.Polling_Required := True; goto Line_Loop_Continue; - -- Ignore pragma Pure (System) - - elsif System_Text (P .. P + 20) = "pragma Pure (System);" then - P := P + 21; - goto Line_Loop_Continue; - -- Queuing Policy elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then @@ -503,9 +498,20 @@ package body Targparm is Opt.Task_Dispatching_Policy_Sloc := System_Location; goto Line_Loop_Continue; - -- No other pragmas are permitted + -- No other configuration pragmas are permitted elsif System_Text (P .. P + 6) = "pragma " then + + -- Special exception, we allow pragma Pure (System) appearing in + -- column one. This is an obsolete usage which may show up in old + -- tests with an obsolete version of system.ads, so we recognize + -- and ignore it to make life easier in handling such tests. + + if System_Text (P .. P + 20) = "pragma Pure (System);" then + P := P + 21; + goto Line_Loop_Continue; + end if; + Set_Standard_Error; Write_Line ("unrecognized line in system.ads: "); @@ -666,7 +672,6 @@ package body Targparm is when MOV => Machine_Overflows_On_Target := Result; when MRN => Machine_Rounds_On_Target := Result; when PAS => Preallocated_Stacks_On_Target := Result; - when RTX => RTX_RTSS_Kernel_Module_On_Target := Result; when SAG => Support_Aggregates_On_Target := Result; when SAP => Support_Atomic_Primitives_On_Target := Result; when SCA => Support_Composite_Assign_On_Target := Result; @@ -678,8 +683,6 @@ package body Targparm is when SSL => Suppress_Standard_Library_On_Target := Result; when SNZ => Signed_Zeros_On_Target := Result; when UAM => Use_Ada_Main_Program_Name_On_Target := Result; - when VMS => OpenVMS_On_Target := Result; - when VXF => VAX_Float_On_Target := Result; when ZCD => ZCX_By_Default_On_Target := Result; goto Line_Loop_Continue; @@ -716,13 +719,6 @@ package body Targparm is end if; end loop Line_Loop; - -- Now that OpenVMS_On_Target has been given its definitive value, - -- change the multi-unit index character from '~' to '$' for OpenVMS. - - if OpenVMS_On_Target then - Multi_Unit_Index_Character := '$'; - end if; - if Fatal then raise Unrecoverable_Error; end if; diff --git a/main/gcc/ada/targparm.ads b/main/gcc/ada/targparm.ads index 21f2d6db416..b7d40c67498 100644 --- a/main/gcc/ada/targparm.ads +++ b/main/gcc/ada/targparm.ads @@ -179,13 +179,13 @@ package Targparm is -- The default values here are used if no value is found in system.ads. -- This should normally happen if the special version of system.ads used - -- by the compiler itself is in use or if the value is only relevant to - -- a particular target (e.g. OpenVMS, AAMP). The default values are - -- suitable for use in normal environments. This approach allows the - -- possibility of new versions of the compiler (possibly with new system - -- parameters added) being used to compile older versions of the compiler - -- sources, as well as avoiding duplicating values in all system-*.ads - -- files for flags that are used on a few platforms only. + -- by the compiler itself is in use or if the value is only relevant to a + -- particular target (e.g. AAMP). The default values are suitable for use + -- in normal environments. This approach allows the possibility of new + -- versions of the compiler (possibly with new system parameters added) + -- being used to compile older versions of the compiler sources, as well as + -- avoiding duplicating values in all system-*.ads files for flags that are + -- used on a few platforms only. -- All these parameters should be regarded as read only by all clients -- of the package. The only way they get modified is by calling the @@ -203,15 +203,6 @@ package Targparm is AAMP_On_Target : Boolean := False; -- Set to True if target is AAMP - OpenVMS_On_Target : Boolean := False; - -- Set to True if target is OpenVMS - - VAX_Float_On_Target : Boolean := False; - -- Set to True if target float format is VAX Float - - RTX_RTSS_Kernel_Module_On_Target : Boolean := False; - -- Set to True if target is RTSS module for RTX - type Virtual_Machine_Kind is (No_VM, JVM_Target, CLI_Target); VM_Target : Virtual_Machine_Kind := No_VM; -- Kind of virtual machine targetted diff --git a/main/gcc/ada/tb-alvms.c b/main/gcc/ada/tb-alvms.c deleted file mode 100644 index 1fd837e150c..00000000000 --- a/main/gcc/ada/tb-alvms.c +++ /dev/null @@ -1,395 +0,0 @@ -/**************************************************************************** - * * - * GNAT RUN-TIME COMPONENTS * - * * - * T R A C E B A C K - A l p h a / V M S * - * * - * C Implementation File * - * * - * Copyright (C) 2003-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. * - * * - * 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 * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - - -/* Alpha VMS requires a special treatment due to the complexity of the ABI. - What is here is along the lines of what the MD_FALLBACK_FRAME_STATE_FOR - macro does for frame unwinding during exception propagation. This file is - #included within tracebak.c in the appropriate case. - - Most of the contents is directed by the OpenVMS/Alpha Conventions (ABI) - document, sections of which we will refer to as ABI-. */ - -#include -#include -#include -#include - -/* A couple of items missing from the header file included above. */ -extern void * SYS$GL_CALL_HANDL; -#define PDSC$M_BASE_FRAME (1 << 10) - -/* Registers are 64bit wide and addresses are 32bit wide on alpha-vms. */ -typedef void * ADDR; -typedef unsigned long long REG; - -#define REG_AT(addr) (*(REG *)(addr)) - -#define AS_REG(addr) ((REG)(unsigned long)(addr)) -#define AS_ADDR(reg) ((ADDR)(unsigned long)(reg)) -#define ADDR_IN(reg) (AS_ADDR(reg)) - -/* The following structure defines the state maintained during the - unwinding process. */ -typedef struct -{ - ADDR pc; /* Address of the call insn involved in the chain. */ - ADDR sp; /* Stack Pointer at the time of this call. */ - ADDR fp; /* Frame Pointer at the time of this call. */ - - /* The values above are fetched as saved REGisters on the stack. They are - typed ADDR because this is what the values in those registers are. */ - - /* Values of the registers saved by the functions in the chain, - incrementally updated through consecutive calls to the "unwind" function - below. */ - REG saved_regs [32]; -} frame_state_t; - -/* Shortcuts for saved_regs of specific interest: - - Frame Pointer is r29, - Stack Pointer is r30, - Return Address is r26, - Procedure Value is r27. - - This is from ABI-3.1.1 [Integer Registers]. */ - -#define saved_fpr saved_regs[29] -#define saved_spr saved_regs[30] -#define saved_rar saved_regs[26] -#define saved_pvr saved_regs[27] - -/* Special values for saved_rar, used to control the overall unwinding - process. */ -#define RA_UNKNOWN ((REG)~0) -#define RA_STOP ((REG)0) - -/* We still use a number of macros similar to the ones for the generic - __gnat_backtrace implementation. */ -#define PC_ADJUST 4 -#define STOP_FRAME (frame_state.saved_rar == RA_STOP) - -/* Compute Procedure Value from Frame Pointer value. This follows the rules - in ABI-3.6.1 [Current Procedure]. */ -#define PV_FOR(FP) \ - (((FP) != 0) \ - ? (((REG_AT (FP) & 0x7) == 0) ? *(PDSCDEF **)(FP) : (PDSCDEF *)(FP)) : 0) - - -/********** - * unwind * - **********/ - -/* Helper for __gnat_backtrace. - - FS represents some call frame, identified by a pc and associated frame - pointer in FS->pc and FS->fp. FS->saved_regs contains the state of the - general registers upon entry in this frame. Of most interest in this set - are the saved return address and frame pointer registers, which actually - allow identifying the caller's frame. - - This routine "unwinds" the input frame state by adjusting it to eventually - represent its caller's frame. The basic principle is to shift the fp and pc - saved values into the current state, and then compute the corresponding new - saved registers set. - - If the call chain goes through a signal handler, special processing is - required when we process the kernel frame which has called the handler, to - switch it to the interrupted context frame. */ - -#define K_HANDLER_FRAME(fs) (PV_FOR ((fs)->fp) == SYS$GL_CALL_HANDL) - -static void unwind_regular_code (frame_state_t * fs); -static void unwind_kernel_handler (frame_state_t * fs); - -void -unwind (frame_state_t * fs) -{ - /* Don't do anything if requested so. */ - if (fs->saved_rar == RA_STOP) - return; - - /* Retrieve the values of interest computed during the previous - call. PC_ADJUST gets us from the return address to the call insn - address. */ - fs->pc = ADDR_IN (fs->saved_rar) - PC_ADJUST; - fs->sp = ADDR_IN (fs->saved_spr); - fs->fp = ADDR_IN (fs->saved_fpr); - - /* Unless we are able to determine otherwise, set the frame state's - saved return address such that the unwinding process will stop. */ - fs->saved_rar = RA_STOP; - - /* Now we want to update fs->saved_regs to reflect the state of the caller - of the procedure described by pc/fp. - - The condition to check for a special kernel frame which has called a - signal handler is stated in ABI-6.7.1 [Signaler's Registers] : "The frame - of the call to the handler can be identified by the return address of - SYS$CALL_HANDL+4". We use the equivalent procedure value identification - here because SYS$CALL_HANDL appears to be undefined. */ - - if (K_HANDLER_FRAME (fs)) - unwind_kernel_handler (fs); - else - unwind_regular_code (fs); -} - -/*********************** - * unwind_regular_code * - ***********************/ - -/* Helper for unwind, for the case of unwinding through regular code which - is not a signal handler. */ - -static void -unwind_regular_code (frame_state_t * fs) -{ - PDSCDEF * pv = PV_FOR (fs->fp); - - ADDR frame_base; - - /* Use the procedure value to unwind, in a way depending on the kind of - procedure at hand. See ABI-3.3 [Procedure Representation] and ABI-3.4 - [Procedure Types]. */ - - if (pv == 0 - || pv->pdsc$w_flags & PDSC$M_BASE_FRAME) - return; - - frame_base - = (pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp; - - switch (pv->pdsc$w_flags & 0xf) - { - case PDSC$K_KIND_FP_STACK: - /* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers - from the Register Save Area in the frame. */ - { - ADDR rsa_base = frame_base + pv->pdsc$w_rsa_offset; - int i, j; - - fs->saved_rar = REG_AT (rsa_base); - fs->saved_pvr = REG_AT (frame_base); - - for (i = 0, j = 0; i < 32; i++) - if (pv->pdsc$l_ireg_mask & (1 << i)) - fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j); - - /* Note that the loop above is guaranteed to set fs->saved_fpr, - because "The preserved register set must always include R29(FP) - since it will always be used." (ABI-3.4.3.4 [Register Save Area for - All Stack Frames]). - - Also note that we need to run through all the registers to ensure - that unwinding through register procedures (see below) gets the - right values out of the saved_regs array. */ - } - break; - - case PDSC$K_KIND_FP_REGISTER: - /* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from - the registers where they have been saved. */ - { - fs->saved_rar = fs->saved_regs[pv->pdsc$b_save_ra]; - fs->saved_fpr = fs->saved_regs[pv->pdsc$b_save_fp]; - } - break; - - default: - /* ??? Are we supposed to ever get here ? Don't think so. */ - break; - } - - /* SP is actually never part of the saved registers area, so we use the - corresponding entry in the saved_regs array to manually keep track of - it's evolution. */ - fs->saved_spr = AS_REG (frame_base) + pv->pdsc$l_size; -} - -/************************* - * unwind_kernel_handler * - *************************/ - -/* Helper for unwind, for the specific case of unwinding through a signal - handler. - - The input frame state describes the kernel frame which has called a signal - handler. We fill the corresponding saved_regs to have it's "caller" frame - represented as the interrupted context. */ - -static void -unwind_kernel_handler (frame_state_t * fs) -{ - PDSCDEF * pv = PV_FOR (fs->fp); - - CHFDEF1 *sigargs; - CHFDEF2 *mechargs; - - /* Retrieve the arguments passed to the handler, by way of a VMS service - providing the corresponding "Invocation Context Block". */ - { - long handler_ivhandle; - INVO_CONTEXT_BLK handler_ivcb; - - CHFCTX *chfctx; - - handler_ivcb.libicb$q_ireg [29] = AS_REG (fs->fp); - handler_ivcb.libicb$q_ireg [30] = 0; - - handler_ivhandle = LIB$GET_INVO_HANDLE (&handler_ivcb); - - if ((LIB$GET_INVO_CONTEXT (handler_ivhandle, &handler_ivcb) & 1) != 1) - return; - - chfctx = (CHFCTX *) AS_ADDR (handler_ivcb.libicb$ph_chfctx_addr); - - sigargs = (CHFDEF1 *) AS_ADDR (chfctx->chfctx$q_sigarglst); - mechargs = (CHFDEF2 *) AS_ADDR (chfctx->chfctx$q_mcharglst); - } - - /* Compute the saved return address as the PC of the instruction causing the - condition, accounting for the fact that it will be adjusted by the next - call to "unwind" as if it was an actual call return address. */ - { - /* ABI-6.5.1.1 [Signal Argument Vector]: The signal occurrence address - is available from the sigargs argument to the handler, designed to - support both 32 and 64 bit addresses. The initial reference we get - is a pointer to the 32bit form, from which one may extract a pointer - to the 64bit version if need be. We work directly from the 32bit - form here. */ - - /* The sigargs vector structure for 32bits addresses is: - - <......32bit......> - +-----------------+ - | Vsize | :chf$is_sig_args - +-----------------+ -+- - | Condition Value | : [0] - +-----------------+ : - | ... | : - +-----------------+ : vector of Vsize entries - | Signal PC | : - +-----------------+ : - | PS | : [Vsize - 1] - +-----------------+ -+- - - */ - - unsigned long * sigargs_vector - = ((unsigned long *) (&sigargs->chf$is_sig_args)) + 1; - - long sigargs_vsize - = sigargs->chf$is_sig_args; - - fs->saved_rar = (REG) sigargs_vector [sigargs_vsize - 2] + PC_ADJUST; - } - - fs->saved_spr = RA_UNKNOWN; - fs->saved_fpr = (REG) mechargs->chf$q_mch_frame; - fs->saved_pvr = (REG) mechargs->chf$q_mch_savr27; - - fs->saved_regs[16] = (REG) mechargs->chf$q_mch_savr16; - fs->saved_regs[17] = (REG) mechargs->chf$q_mch_savr17; - fs->saved_regs[18] = (REG) mechargs->chf$q_mch_savr18; - fs->saved_regs[19] = (REG) mechargs->chf$q_mch_savr19; - fs->saved_regs[20] = (REG) mechargs->chf$q_mch_savr20; -} - -/* Structure representing a traceback entry in the tracebacks array to be - filled by __gnat_backtrace below. - - !! This should match what is in System.Traceback_Entries, so beware of - !! the REG/ADDR difference here. - - The use of a structure is motivated by the potential necessity of having - several fields to fill for each entry, for instance if later calls to VMS - system functions need more than just a mere PC to compute info on a frame - (e.g. for non-symbolic->symbolic translation purposes). */ -typedef struct { - ADDR pc; /* Program Counter. */ - ADDR pv; /* Procedure Value. */ -} tb_entry_t; - -/******************** - * __gnat_backtrace * - ********************/ - -int -__gnat_backtrace (void **array, int size, - void *exclude_min, void *exclude_max, int skip_frames) -{ - int cnt; - - tb_entry_t * tbe = (tb_entry_t *)&array [0]; - - frame_state_t frame_state; - - /* Setup the frame state before initiating the unwinding sequence. */ - register REG this_FP __asm__("$29"); - register REG this_SP __asm__("$30"); - - frame_state.saved_fpr = this_FP; - frame_state.saved_spr = this_SP; - frame_state.saved_rar = RA_UNKNOWN; - - unwind (&frame_state); - - /* At this point frame_state describes this very function. Skip the - requested number of calls. */ - for (cnt = 0; cnt < skip_frames; cnt ++) - unwind (&frame_state); - - /* Now consider each frame as a potential candidate for insertion inside - the provided array. */ - cnt = 0; - while (cnt < size) - { - /* Stop if either the frame contents or the unwinder say so. */ - if (STOP_FRAME) - break; - - if (! K_HANDLER_FRAME (&frame_state) - && (frame_state.pc < exclude_min || frame_state.pc > exclude_max)) - { - tbe->pc = (ADDR) frame_state.pc; - tbe->pv = (ADDR) PV_FOR (frame_state.fp); - - cnt ++; - tbe ++; - } - - unwind (&frame_state); - } - - return cnt; -} diff --git a/main/gcc/ada/tb-alvxw.c b/main/gcc/ada/tb-alvxw.c deleted file mode 100644 index 4f743a110a7..00000000000 --- a/main/gcc/ada/tb-alvxw.c +++ /dev/null @@ -1,940 +0,0 @@ -/**************************************************************************** - * * - * GNAT RUN-TIME COMPONENTS * - * * - * T R A C E B A C K - A l p h a / V x W o r k s * - * * - * C Implementation File * - * * - * Copyright (C) 2000-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. * - * * - * 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 * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - -/* Alpha vxWorks requires a special, complex treatment that is extracted - from GDB. This file is #included within tracebak.c in the appropriate - case. */ - -#include -#include -#include -#include - -extern void kerTaskEntry(void); - -/* We still use a number of macros similar to the ones for the generic - __gnat_backtrace implementation. */ -#define SKIP_FRAME 1 -#define PC_ADJUST -4 - -#define STOP_FRAME \ - (current == NULL \ - || ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \ - && current->pc >= (CORE_ADDR) &kerTaskEntry)) - -/* Register numbers of various important registers. - Note that most of these values are "real" register numbers, - and correspond to the general registers of the machine, - and FP_REGNUM is a "phony" register number which is too large - to be an actual register number as far as the user is concerned - but serves to get the desired value when passed to read_register. */ - -#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */ -#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */ -#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */ -#define SP_REGNUM 30 /* Contains address of top of stack */ -#define RA_REGNUM 26 /* Contains return address value */ -#define FP0_REGNUM 32 /* Floating point register 0 */ -#define PC_REGNUM 64 /* Contains program counter */ -#define NUM_REGS 66 - -#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000 - -#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS)) -#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci) - -#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe) - -#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \ - ((CHAIN) != 0 \ - && !inside_entry_file (FRAME_SAVED_PC (THISFRAME))) - -#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME)) - -#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN) - -#define INIT_FRAME_PC(FROMLEAF, PREV) - -#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \ - (PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \ - : (PREV)->next ? FRAME_SAVED_PC ((PREV)->next) : read_pc ()); - -#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME) - -typedef unsigned long long int bfd_vma; - -typedef bfd_vma CORE_ADDR; - -typedef struct pdr -{ - bfd_vma adr; /* memory address of start of procedure */ - long isym; /* start of local symbol entries */ - long iline; /* start of line number entries*/ - long regmask; /* save register mask */ - long regoffset; /* save register offset */ - long iopt; /* start of optimization symbol entries*/ - long fregmask; /* save floating point register mask */ - long fregoffset; /* save floating point register offset */ - long frameoffset; /* frame size */ - short framereg; /* frame pointer register */ - short pcreg; /* offset or reg of return pc */ - long lnLow; /* lowest line in the procedure */ - long lnHigh; /* highest line in the procedure */ - bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */ - /* These fields are new for 64 bit ECOFF. */ - unsigned gp_prologue : 8; /* byte size of GP prologue */ - unsigned gp_used : 1; /* true if the procedure uses GP */ - unsigned reg_frame : 1; /* true if register frame procedure */ - unsigned prof : 1; /* true if compiled with -pg */ - unsigned reserved : 13; /* reserved: must be zero */ - unsigned localoff : 8; /* offset of local variables from vfp */ -} PDR; - -typedef struct alpha_extra_func_info -{ - long numargs; /* number of args to procedure (was iopt) */ - PDR pdr; /* Procedure descriptor record */ -} -*alpha_extra_func_info_t; - -struct frame_info -{ - /* Nominal address of the frame described. See comments at FRAME_FP - about what this means outside the *FRAME* macros; in the *FRAME* - macros, it can mean whatever makes most sense for this machine. */ - CORE_ADDR frame; - - /* Address at which execution is occurring in this frame. For the - innermost frame, it's the current pc. For other frames, it is a - pc saved in the next frame. */ - CORE_ADDR pc; - - /* For each register, address of where it was saved on entry to the - frame, or zero if it was not saved on entry to this frame. This - includes special registers such as pc and fp saved in special - ways in the stack frame. The SP_REGNUM is even more special, the - address here is the sp for the next frame, not the address where - the sp was saved. Allocated by frame_saved_regs_zalloc () which - is called and initialized by FRAME_INIT_SAVED_REGS. */ - CORE_ADDR *saved_regs; /*NUM_REGS */ - - int localoff; - int pc_reg; - alpha_extra_func_info_t proc_desc; - - /* Pointers to the next and previous frame_info's in the frame cache. */ - struct frame_info *next, *prev; -}; - -struct frame_saved_regs -{ - /* For each register R (except the SP), regs[R] is the address at - which it was saved on entry to the frame, or zero if it was not - saved on entry to this frame. This includes special registers - such as pc and fp saved in special ways in the stack frame. - - regs[SP_REGNUM] is different. It holds the actual SP, not the - address at which it was saved. */ - - CORE_ADDR regs[NUM_REGS]; -}; - -static CORE_ADDR theRegisters[32]; - -/* Prototypes for local functions. */ - -static CORE_ADDR read_next_frame_reg (struct frame_info *, int); -static CORE_ADDR heuristic_proc_start (CORE_ADDR); -static int alpha_about_to_return (CORE_ADDR pc); -static void init_extra_frame_info (struct frame_info *); -static CORE_ADDR alpha_frame_chain (struct frame_info *); -static CORE_ADDR alpha_frame_saved_pc (struct frame_info *frame); -static void *trace_alloc (unsigned int); -static struct frame_info *create_new_frame (CORE_ADDR, CORE_ADDR); - -static alpha_extra_func_info_t -heuristic_proc_desc (CORE_ADDR, CORE_ADDR, struct frame_info *, - struct frame_saved_regs *); - -static alpha_extra_func_info_t -find_proc_desc (CORE_ADDR, struct frame_info *, struct frame_saved_regs *); - -/* Heuristic_proc_start may hunt through the text section for a long - time across a 2400 baud serial line. Allows the user to limit this - search. */ -static unsigned int heuristic_fence_post = 1<<16; - -/* Layout of a stack frame on the alpha: - - | | - pdr members: | 7th ... nth arg, | - | `pushed' by caller. | - | | -----------------|-------------------------------|<-- old_sp == vfp - ^ ^ ^ ^ | | - | | | | | | - | |localoff | Copies of 1st .. 6th | - | | | | | argument if necessary. | - | | | v | | - | | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS - | | | | | - | | | | Locals and temporaries. | - | | | | | - | | | |-------------------------------| - | | | | | - |-fregoffset | Saved float registers. | - | | | | F9 | - | | | | . | - | | | | . | - | | | | F2 | - | | v | | - | | -------|-------------------------------| - | | | | - | | | Saved registers. | - | | | S6 | - |-regoffset | . | - | | | . | - | | | S0 | - | | | pdr.pcreg | - | v | | - | ----------|-------------------------------| - | | | - frameoffset | Argument build area, gets | - | | 7th ... nth arg for any | - | | called procedure. | - v | | - -------------|-------------------------------|<-- sp - | | */ - -#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */ -#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */ -#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */ -#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset) -#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg) -#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask) -#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask) -#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset) -#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset) -#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg) -#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff) - -/* Local storage allocation/deallocation functions. trace_alloc does - a malloc, but also chains allocated blocks on trace_alloc_chain, so - they may all be freed on exit from __gnat_backtrace. */ - -struct alloc_chain -{ - struct alloc_chain *next; - double x[0]; -}; -struct alloc_chain *trace_alloc_chain; - -static void * -trace_alloc (unsigned int n) -{ - struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain)); - - result->next = trace_alloc_chain; - trace_alloc_chain = result; - return (void*) result->x; -} - -static void -free_trace_alloc (void) -{ - while (trace_alloc_chain != 0) - { - struct alloc_chain *old = trace_alloc_chain; - - trace_alloc_chain = trace_alloc_chain->next; - free (old); - } -} - -/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0 - otherwise. */ - -static int -read_memory_safe4 (CORE_ADDR addr, unsigned int *dest) -{ - *dest = *((unsigned int*) addr); - return 0; -} - -/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0 - otherwise. */ - -static int -read_memory_safe8 (CORE_ADDR addr, CORE_ADDR *dest) -{ - *dest = *((CORE_ADDR*) addr); - return 0; -} - -static CORE_ADDR -read_register (int regno) -{ - if (regno >= 0 && regno < 31) - return theRegisters[regno]; - - return (CORE_ADDR) 0; -} - -static void -frame_saved_regs_zalloc (struct frame_info *fi) -{ - fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS); - memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS); -} - -static void * -frame_obstack_alloc (unsigned long size) -{ - return (void *) trace_alloc (size); -} - -static int -inside_entry_file (CORE_ADDR addr) -{ - if (addr == 0) - return 1; - else - return 0; -} - -static CORE_ADDR -alpha_saved_pc_after_call (struct frame_info *frame) -{ - CORE_ADDR pc = frame->pc; - alpha_extra_func_info_t proc_desc; - int pcreg; - - proc_desc = find_proc_desc (pc, frame->next, NULL); - pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM; - - return read_register (pcreg); -} - -/* Guaranteed to set frame->saved_regs to some values (it never leaves it - NULL). */ - -static void -alpha_find_saved_regs (struct frame_info *frame) -{ - int ireg; - CORE_ADDR reg_position; - unsigned long mask; - alpha_extra_func_info_t proc_desc; - int returnreg; - - frame_saved_regs_zalloc (frame); - - /* If it is the frame for __sigtramp, the saved registers are located in a - sigcontext structure somewhere on the stack. __sigtramp passes a pointer - to the sigcontext structure on the stack. If the stack layout for - __sigtramp changes, or if sigcontext offsets change, we might have to - update this code. */ - -#ifndef SIGFRAME_PC_OFF -#define SIGFRAME_PC_OFF (2 * 8) -#define SIGFRAME_REGSAVE_OFF (4 * 8) -#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8) -#endif - - proc_desc = frame->proc_desc; - if (proc_desc == NULL) - /* I'm not sure how/whether this can happen. Normally when we can't - find a proc_desc, we "synthesize" one using heuristic_proc_desc - and set the saved_regs right away. */ - return; - - /* Fill in the offsets for the registers which gen_mask says - were saved. */ - - reg_position = frame->frame + PROC_REG_OFFSET (proc_desc); - mask = PROC_REG_MASK (proc_desc); - - returnreg = PROC_PC_REG (proc_desc); - - /* Note that RA is always saved first, regardless of its actual - register number. */ - if (mask & (1 << returnreg)) - { - frame->saved_regs[returnreg] = reg_position; - reg_position += 8; - mask &= ~(1 << returnreg); /* Clear bit for RA so we - don't save again later. */ - } - - for (ireg = 0; ireg <= 31; ireg++) - if (mask & (1 << ireg)) - { - frame->saved_regs[ireg] = reg_position; - reg_position += 8; - } - - /* Fill in the offsets for the registers which float_mask says - were saved. */ - - reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc); - mask = PROC_FREG_MASK (proc_desc); - - for (ireg = 0; ireg <= 31; ireg++) - if (mask & (1 << ireg)) - { - frame->saved_regs[FP0_REGNUM + ireg] = reg_position; - reg_position += 8; - } - - frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg]; -} - -static CORE_ADDR -read_next_frame_reg (struct frame_info *fi, int regno) -{ - CORE_ADDR result; - for (; fi; fi = fi->next) - { - /* We have to get the saved sp from the sigcontext - if it is a signal handler frame. */ - if (regno == SP_REGNUM) - return fi->frame; - else - { - if (fi->saved_regs == 0) - alpha_find_saved_regs (fi); - - if (fi->saved_regs[regno]) - { - if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0) - return result; - else - return 0; - } - } - } - - return read_register (regno); -} - -static CORE_ADDR -alpha_frame_saved_pc (struct frame_info *frame) -{ - return read_next_frame_reg (frame, frame->pc_reg); -} - -static struct alpha_extra_func_info temp_proc_desc; - -/* Nonzero if instruction at PC is a return instruction. "ret - $zero,($ra),1" on alpha. */ - -static int -alpha_about_to_return (CORE_ADDR pc) -{ - int inst; - - read_memory_safe4 (pc, &inst); - return inst == 0x6bfa8001; -} - -/* A heuristically computed start address for the subprogram - containing address PC. Returns 0 if none detected. */ - -static CORE_ADDR -heuristic_proc_start (CORE_ADDR pc) -{ - CORE_ADDR start_pc = pc; - CORE_ADDR fence = start_pc - heuristic_fence_post; - - if (start_pc == 0) - return 0; - - if (heuristic_fence_post == UINT_MAX - || fence < VM_MIN_ADDRESS) - fence = VM_MIN_ADDRESS; - - /* search back for previous return */ - for (start_pc -= 4; ; start_pc -= 4) - { - if (start_pc < fence) - return 0; - else if (alpha_about_to_return (start_pc)) - break; - } - - start_pc += 4; /* skip return */ - return start_pc; -} - -static alpha_extra_func_info_t -heuristic_proc_desc (CORE_ADDR start_pc, - CORE_ADDR limit_pc, - struct frame_info *next_frame, - struct frame_saved_regs *saved_regs_p) -{ - CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM); - CORE_ADDR cur_pc; - int frame_size; - int has_frame_reg = 0; - unsigned long reg_mask = 0; - int pcreg = -1; - - if (start_pc == 0) - return 0; - - memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc)); - if (saved_regs_p != 0) - memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs)); - - PROC_LOW_ADDR (&temp_proc_desc) = start_pc; - - if (start_pc + 200 < limit_pc) - limit_pc = start_pc + 200; - - frame_size = 0; - for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4) - { - unsigned int word; - int status; - - status = read_memory_safe4 (cur_pc, &word); - if (status) - return 0; - - if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */ - { - if (word & 0x8000) - frame_size += (-word) & 0xffff; - else - /* Exit loop if a positive stack adjustment is found, which - usually means that the stack cleanup code in the function - epilogue is reached. */ - break; - } - else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */ - && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */ - { - int reg = (word & 0x03e00000) >> 21; - - reg_mask |= 1 << reg; - if (saved_regs_p != 0) - saved_regs_p->regs[reg] = sp + (short) word; - - /* Starting with OSF/1-3.2C, the system libraries are shipped - without local symbols, but they still contain procedure - descriptors without a symbol reference. GDB is currently - unable to find these procedure descriptors and uses - heuristic_proc_desc instead. - As some low level compiler support routines (__div*, __add*) - use a non-standard return address register, we have to - add some heuristics to determine the return address register, - or stepping over these routines will fail. - Usually the return address register is the first register - saved on the stack, but assembler optimization might - rearrange the register saves. - So we recognize only a few registers (t7, t9, ra) within - the procedure prologue as valid return address registers. - If we encounter a return instruction, we extract the - return address register from it. - - FIXME: Rewriting GDB to access the procedure descriptors, - e.g. via the minimal symbol table, might obviate this hack. */ - if (pcreg == -1 - && cur_pc < (start_pc + 80) - && (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)) - pcreg = reg; - } - else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */ - pcreg = (word >> 16) & 0x1f; - else if (word == 0x47de040f) /* bis sp,sp fp */ - has_frame_reg = 1; - } - - if (pcreg == -1) - { - /* If we haven't found a valid return address register yet, - keep searching in the procedure prologue. */ - while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80)) - { - unsigned int word; - - if (read_memory_safe4 (cur_pc, &word)) - break; - cur_pc += 4; - - if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */ - && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */ - { - int reg = (word & 0x03e00000) >> 21; - - if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM) - { - pcreg = reg; - break; - } - } - else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */ - { - pcreg = (word >> 16) & 0x1f; - break; - } - } - } - - if (has_frame_reg) - PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM; - else - PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM; - - PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size; - PROC_REG_MASK (&temp_proc_desc) = reg_mask; - PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg; - PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */ - - return &temp_proc_desc; -} - -static alpha_extra_func_info_t -find_proc_desc (CORE_ADDR pc, - struct frame_info *next_frame, - struct frame_saved_regs *saved_regs) -{ - CORE_ADDR startaddr; - - /* If heuristic_fence_post is nonzero, determine the procedure - start address by examining the instructions. - This allows us to find the start address of static functions which - have no symbolic information, as startaddr would have been set to - the preceding global function start address by the - find_pc_partial_function call above. */ - startaddr = heuristic_proc_start (pc); - - return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs); -} - -static CORE_ADDR -alpha_frame_chain (struct frame_info *frame) -{ - alpha_extra_func_info_t proc_desc; - CORE_ADDR saved_pc = FRAME_SAVED_PC (frame); - - if (saved_pc == 0 || inside_entry_file (saved_pc)) - return 0; - - proc_desc = find_proc_desc (saved_pc, frame, NULL); - if (!proc_desc) - return 0; - - /* If no frame pointer and frame size is zero, we must be at end - of stack (or otherwise hosed). If we don't check frame size, - we loop forever if we see a zero size frame. */ - if (PROC_FRAME_REG (proc_desc) == SP_REGNUM - && PROC_FRAME_OFFSET (proc_desc) == 0) - return 0; - else - return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc)) - + PROC_FRAME_OFFSET (proc_desc); -} - -static void -init_extra_frame_info (struct frame_info *frame) -{ - struct frame_saved_regs temp_saved_regs; - alpha_extra_func_info_t proc_desc = - find_proc_desc (frame->pc, frame->next, &temp_saved_regs); - - frame->saved_regs = NULL; - frame->localoff = 0; - frame->pc_reg = RA_REGNUM; - frame->proc_desc = proc_desc; - - if (proc_desc) - { - /* Get the locals offset and the saved pc register from the - procedure descriptor, they are valid even if we are in the - middle of the prologue. */ - frame->localoff = PROC_LOCALOFF (proc_desc); - frame->pc_reg = PROC_PC_REG (proc_desc); - - /* Fixup frame-pointer - only needed for top frame */ - - /* This may not be quite right, if proc has a real frame register. - Get the value of the frame relative sp, procedure might have been - interrupted by a signal at it's very start. */ - if (frame->pc == PROC_LOW_ADDR (proc_desc)) - frame->frame = read_next_frame_reg (frame->next, SP_REGNUM); - else - frame->frame - = (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc)) - + PROC_FRAME_OFFSET (proc_desc)); - - frame->saved_regs - = (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS); - memcpy - (frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS); - frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM]; - } -} - -/* Create an arbitrary (i.e. address specified by user) or innermost frame. - Always returns a non-NULL value. */ - -static struct frame_info * -create_new_frame (CORE_ADDR addr, CORE_ADDR pc) -{ - struct frame_info *fi; - - fi = (struct frame_info *) - trace_alloc (sizeof (struct frame_info)); - - /* Arbitrary frame */ - fi->next = NULL; - fi->prev = NULL; - fi->frame = addr; - fi->pc = pc; - -#ifdef INIT_EXTRA_FRAME_INFO - INIT_EXTRA_FRAME_INFO (0, fi); -#endif - - return fi; -} - -static CORE_ADDR current_pc; - -static void -set_current_pc (void) -{ - current_pc = (CORE_ADDR) __builtin_return_address (0); -} - -static CORE_ADDR -read_pc (void) -{ - return current_pc; -} - -static struct frame_info * -get_current_frame (void) -{ - return create_new_frame (0, read_pc ()); -} - -/* Return the frame that called FI. - If FI is the original frame (it has no caller), return 0. */ - -static struct frame_info * -get_prev_frame (struct frame_info *next_frame) -{ - CORE_ADDR address = 0; - struct frame_info *prev; - int fromleaf = 0; - - /* If we have the prev one, return it */ - if (next_frame->prev) - return next_frame->prev; - - /* On some machines it is possible to call a function without - setting up a stack frame for it. On these machines, we - define this macro to take two args; a frameinfo pointer - identifying a frame and a variable to set or clear if it is - or isn't leafless. */ - - /* Two macros defined in tm.h specify the machine-dependent - actions to be performed here. - - First, get the frame's chain-pointer. If that is zero, the frame - is the outermost frame or a leaf called by the outermost frame. - This means that if start calls main without a frame, we'll return - 0 (which is fine anyway). - - Nope; there's a problem. This also returns when the current - routine is a leaf of main. This is unacceptable. We move - this to after the ffi test; I'd rather have backtraces from - start go curfluy than have an abort called from main not show - main. */ - - address = FRAME_CHAIN (next_frame); - if (!FRAME_CHAIN_VALID (address, next_frame)) - return 0; - address = FRAME_CHAIN_COMBINE (address, next_frame); - - if (address == 0) - return 0; - - prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info)); - - prev->saved_regs = NULL; - if (next_frame) - next_frame->prev = prev; - - prev->next = next_frame; - prev->prev = (struct frame_info *) 0; - prev->frame = address; - - /* This change should not be needed, FIXME! We should - determine whether any targets *need* INIT_FRAME_PC to happen - after INIT_EXTRA_FRAME_INFO and come up with a simple way to - express what goes on here. - - INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame - (where the PC is already set up) and here (where it isn't). - INIT_FRAME_PC is only called from here, always after - INIT_EXTRA_FRAME_INFO. - - The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC - value (which hasn't been set yet). Some other machines appear to - require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo. - - We shouldn't need INIT_FRAME_PC_FIRST to add more complication to - an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92. - - Assuming that some machines need INIT_FRAME_PC after - INIT_EXTRA_FRAME_INFO, one possible scheme: - - SETUP_INNERMOST_FRAME() - Default version is just create_new_frame (read_fp ()), - read_pc ()). Machines with extra frame info would do that (or the - local equivalent) and then set the extra fields. - INIT_PREV_FRAME(fromleaf, prev) - Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should - also return a flag saying whether to keep the new frame, or - whether to discard it, because on some machines (e.g. mips) it - is really awkward to have FRAME_CHAIN_VALID called *before* - INIT_EXTRA_FRAME_INFO (there is no good way to get information - deduced in FRAME_CHAIN_VALID into the extra fields of the new frame). - std_frame_pc(fromleaf, prev) - This is the default setting for INIT_PREV_FRAME. It just does what - the default INIT_FRAME_PC does. Some machines will call it from - INIT_PREV_FRAME (either at the beginning, the end, or in the middle). - Some machines won't use it. - kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */ - -#ifdef INIT_FRAME_PC_FIRST - INIT_FRAME_PC_FIRST (fromleaf, prev); -#endif - -#ifdef INIT_EXTRA_FRAME_INFO - INIT_EXTRA_FRAME_INFO (fromleaf, prev); -#endif - - /* This entry is in the frame queue now, which is good since - FRAME_SAVED_PC may use that queue to figure out its value - (see tm-sparc.h). We want the pc saved in the inferior frame. */ - INIT_FRAME_PC (fromleaf, prev); - - /* If ->frame and ->pc are unchanged, we are in the process of getting - ourselves into an infinite backtrace. Some architectures check this - in FRAME_CHAIN or thereabouts, but it seems like there is no reason - this can't be an architecture-independent check. */ - if (next_frame != NULL) - { - if (prev->frame == next_frame->frame - && prev->pc == next_frame->pc) - { - next_frame->prev = NULL; - free (prev); - return NULL; - } - } - - return prev; -} - -#define SAVE(regno,disp) \ - "stq $" #regno ", " #disp "(%0)\n" - -int -__gnat_backtrace (void **array, - int size, - void *exclude_min, - void *exclude_max, - int skip_frames) -{ - struct frame_info* top; - struct frame_info* current; - int cnt; - - /* This function is not thread safe, protect it */ - (*Lock_Task) (); - asm volatile ( - SAVE (9,72) - SAVE (10,80) - SAVE (11,88) - SAVE (12,96) - SAVE (13,104) - SAVE (14,112) - SAVE (15,120) - SAVE (16,128) - SAVE (17,136) - SAVE (18,144) - SAVE (19,152) - SAVE (20,160) - SAVE (21,168) - SAVE (22,176) - SAVE (23,184) - SAVE (24,192) - SAVE (25,200) - SAVE (26,208) - SAVE (27,216) - SAVE (28,224) - SAVE (29,232) - SAVE (30,240) - : : "r" (&theRegisters)); - - trace_alloc_chain = NULL; - set_current_pc (); - - top = current = get_current_frame (); - cnt = 0; - - for (cnt = 0; cnt < skip_frames; cnt += 1) { - current = get_prev_frame (current); - } - - cnt = 0; - while (cnt < size) - { - if (STOP_FRAME) - break; - - if (current->pc < (CORE_ADDR) exclude_min - || current->pc > (CORE_ADDR) exclude_max) - array[cnt++] = (void*) (current->pc + PC_ADJUST); - - current = get_prev_frame (current); - } - - free_trace_alloc (); - (*Unlock_Task) (); - - return cnt; -} diff --git a/main/gcc/ada/tb-ivms.c b/main/gcc/ada/tb-ivms.c deleted file mode 100644 index 3d55c6e8627..00000000000 --- a/main/gcc/ada/tb-ivms.c +++ /dev/null @@ -1,88 +0,0 @@ -/**************************************************************************** - * * - * GNAT RUN-TIME COMPONENTS * - * * - * T R A C E B A C K - I t a n i u m / V M S * - * * - * C Implementation File * - * * - * Copyright (C) 2007-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. * - * * - * 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 * - * . * - * * - * GNAT was originally developed by the GNAT team at New York University. * - * Extensive contributions were provided by Ada Core Technologies Inc. * - * * - ****************************************************************************/ - -/* Itanium Open/VMS implementation of backtrace. Use ICB (Invocation - Context Block) routines. */ -#include -#include - -/* Declare libicb routines. */ -extern INVO_CONTEXT_BLK *LIB$I64_CREATE_INVO_CONTEXT (void *(*)(size_t), - void (*)(void *), - int); -extern void LIB$I64_FREE_INVO_CONTEXT (INVO_CONTEXT_BLK *); -extern int LIB$I64_GET_CURR_INVO_CONTEXT(INVO_CONTEXT_BLK *); -extern int LIB$I64_GET_PREV_INVO_CONTEXT(INVO_CONTEXT_BLK *); - -/* Gcc internal headers poison malloc. So use xmalloc() when building the - compiler. */ -#ifdef IN_RTS -#define BT_MALLOC malloc -#else -#define BT_MALLOC xmalloc -#endif - -int -__gnat_backtrace (void **array, int size, - void *exclude_min, void *exclude_max, int skip_frames) -{ - INVO_CONTEXT_BLK *ctxt; - int res = 0; - int n = 0; - - /* Create the context. */ - ctxt = LIB$I64_CREATE_INVO_CONTEXT (BT_MALLOC, free, 0); - if (ctxt == NULL) - return 0; - - LIB$I64_GET_CURR_INVO_CONTEXT (ctxt); - - while (1) - { - void *pc = (void *)ctxt->libicb$ih_pc; - if (pc == (void *)0) - break; - if (ctxt->libicb$v_bottom_of_stack) - break; - if (n >= skip_frames && (pc < exclude_min || pc > exclude_max)) - { - array[res++] = (void *)(ctxt->libicb$ih_pc); - if (res == size) - break; - } - n++; - LIB$I64_GET_PREV_INVO_CONTEXT (ctxt); - } - - /* Free the context. */ - LIB$I64_FREE_INVO_CONTEXT (ctxt); - return res; -} diff --git a/main/gcc/ada/tbuild.adb b/main/gcc/ada/tbuild.adb index 17ca12eac8c..cd535cf9ab5 100644 --- a/main/gcc/ada/tbuild.adb +++ b/main/gcc/ada/tbuild.adb @@ -434,12 +434,11 @@ package body Tbuild is Reason : RT_Exception_Code) return Node_Id is begin - pragma Assert (Reason in RT_CE_Exceptions); + pragma Assert (Rkind (Reason) = CE_Reason); return Make_Raise_Constraint_Error (Sloc, Condition => Condition, - Reason => - UI_From_Int (RT_Exception_Code'Pos (Reason))); + Reason => UI_From_Int (RT_Exception_Code'Pos (Reason))); end Make_Raise_Constraint_Error; ------------------------------ @@ -452,12 +451,11 @@ package body Tbuild is Reason : RT_Exception_Code) return Node_Id is begin - pragma Assert (Reason in RT_PE_Exceptions); + pragma Assert (Rkind (Reason) = PE_Reason); return Make_Raise_Program_Error (Sloc, Condition => Condition, - Reason => - UI_From_Int (RT_Exception_Code'Pos (Reason))); + Reason => UI_From_Int (RT_Exception_Code'Pos (Reason))); end Make_Raise_Program_Error; ------------------------------ @@ -470,12 +468,11 @@ package body Tbuild is Reason : RT_Exception_Code) return Node_Id is begin - pragma Assert (Reason in RT_SE_Exceptions); + pragma Assert (Rkind (Reason) = SE_Reason); return Make_Raise_Storage_Error (Sloc, Condition => Condition, - Reason => - UI_From_Int (RT_Exception_Code'Pos (Reason))); + Reason => UI_From_Int (RT_Exception_Code'Pos (Reason))); end Make_Raise_Storage_Error; ------------- @@ -501,9 +498,7 @@ package body Tbuild is begin Start_String; Store_String_Chars (Strval); - return - Make_String_Literal (Sloc, - Strval => End_String); + return Make_String_Literal (Sloc, Strval => End_String); end Make_String_Literal; -------------------- @@ -516,8 +511,7 @@ package body Tbuild is Related_Node : Node_Id := Empty) return Entity_Id is Temp : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name (Id)); + Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id)); begin Set_Related_Expression (Temp, Related_Node); return Temp; @@ -694,6 +688,10 @@ package body Tbuild is Set_Etype (Occurrence, Etype (Def_Id)); end if; + if Ekind (Def_Id) = E_Enumeration_Literal then + Set_Is_Static_Expression (Occurrence, True); + end if; + return Occurrence; end New_Occurrence_Of; diff --git a/main/gcc/ada/tbuild.ads b/main/gcc/ada/tbuild.ads index 67a59d923c3..26869ba8dc8 100644 --- a/main/gcc/ada/tbuild.ads +++ b/main/gcc/ada/tbuild.ads @@ -250,14 +250,21 @@ package Tbuild is -- positive, or if Suffix_Index is negative 1, then a unique serialized -- suffix is added. If Suffix_Index is zero, then no index is appended. - -- Suffix is also a single upper case letter other than O,Q,U,W,X and is a - -- required parameter (T is permitted). The constructed name is stored - -- using Name_Find so that it can be located using a subsequent Name_Find - -- operation (i.e. it is properly hashed into the names table). The upper - -- case letter given as the Suffix argument ensures that the name does - -- not clash with any Ada identifier name. These generated names are - -- permitted, but not required, to be made public by setting the flag - -- Is_Public in the associated entity. + -- Suffix is also a single upper case letter other than O,Q,U,W,X (T is + -- allowed in this context), or a string of such upper case letters. In + -- the case of a string, an initial underscore may be given. + -- + -- The constructed name is stored using Name_Find so that it can be located + -- using a subsequent Name_Find operation (i.e. it is properly hashed into + -- the names table). The upper case letter given as the Suffix argument + -- ensures that the name does not clash with any Ada identifier name. These + -- generated names are permitted, but not required, to be made public by + -- setting the flag Is_Public in the associated entity. + -- + -- Note: it is dubious to make them public if they have serial numbers, + -- since we are counting on the serial numbers being the same for the + -- clients with'ing a package and the actual compilation of the package + -- with full expansion. This is a dubious assumption ??? function New_External_Name (Suffix : Character; @@ -272,6 +279,11 @@ package Tbuild is -- not clash with any Ada identifier name. These generated names are -- permitted, but not required, to be made public by setting the flag -- Is_Public in the associated entity. + -- + -- Note: it is dubious to make these public since they have serial numbers, + -- which means we are counting on the serial numbers being the same for the + -- clients with'ing a package and the actual compilation of the package + -- with full expansion. This is a dubious assumption ??? function New_Internal_Name (Id_Char : Character) return Name_Id; -- Id_Char is an upper case letter other than O,Q,U,W (which are reserved @@ -287,11 +299,17 @@ package Tbuild is -- the Name_Find procedure later on. Names created by New_Internal_Name -- are guaranteed to be consistent from one compilation to another (i.e. -- if the identical unit is compiled with a semantically consistent set - -- of sources, the numbers will be consistent. This means that it is fine + -- of sources, the numbers will be consistent). This means that it is fine -- to use these as public symbols. -- -- Note: Nearly all uses of this function are via calls to Make_Temporary, -- but there are just a few cases where it is called directly. + -- + -- Note: despite the guarantee of consistency stated above, it is dubious + -- to make these public since they have serial numbers, which means we are + -- counting on the serial numbers being the same for the clients with'ing + -- a package and the actual compilation of the package with full expansion. + -- This is a dubious assumption ??? function New_Occurrence_Of (Def_Id : Entity_Id; @@ -300,7 +318,9 @@ package Tbuild is -- of the defining identifier which is passed as its argument. The Entity -- and Etype of the result are set from the given defining identifier as -- follows: Entity is simply a copy of Def_Id. Etype is a copy of Def_Id - -- for types, and a copy of the Etype of Def_Id for other entities. + -- for types, and a copy of the Etype of Def_Id for other entities. Note + -- that Is_Static_Expression is set if this call creates an occurrence of + -- an enumeration literal. function New_Suffixed_Name (Related_Id : Name_Id; diff --git a/main/gcc/ada/tempdir.adb b/main/gcc/ada/tempdir.adb index 7da1ef2d040..4936c26c5aa 100644 --- a/main/gcc/ada/tempdir.adb +++ b/main/gcc/ada/tempdir.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with Hostparm; use Hostparm; with Opt; use Opt; with Output; use Output; @@ -33,9 +32,8 @@ package body Tempdir is Tmpdir_Needs_To_Be_Displayed : Boolean := True; - Tmpdir : constant String := "TMPDIR"; - Gnutmpdir : constant String := "GNUTMPDIR"; - Temp_Dir : String_Access := new String'(""); + Tmpdir : constant String := "TMPDIR"; + Temp_Dir : String_Access := new String'(""); ---------------------- -- Create_Temp_File -- @@ -118,21 +116,7 @@ package body Tempdir is begin if Status then - - -- On VMS, if GNUTMPDIR is defined, use it - - if OpenVMS then - Dir := Getenv (Gnutmpdir); - - -- Otherwise, if GNUTMPDIR is not defined, try TMPDIR - - if Dir'Length = 0 then - Dir := Getenv (Tmpdir); - end if; - - else - Dir := Getenv (Tmpdir); - end if; + Dir := Getenv (Tmpdir); end if; Free (Temp_Dir); diff --git a/main/gcc/ada/tracebak.c b/main/gcc/ada/tracebak.c index 4efb75e61f1..54ec90f674b 100644 --- a/main/gcc/ada/tracebak.c +++ b/main/gcc/ada/tracebak.c @@ -6,7 +6,7 @@ * * * C Implementation File * * * - * Copyright (C) 2000-2012, Free Software Foundation, Inc. * + * Copyright (C) 2000-2014, Free Software Foundation, Inc. * * * * GNAT is 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,19 +95,7 @@ extern void (*Unlock_Task) (void); *-- Target specific implementations --* *-------------------------------------*/ -#if defined (__alpha_vxworks) - -#include "tb-alvxw.c" - -#elif defined (__ALPHA) && defined (__VMS__) - -#include "tb-alvms.c" - -#elif defined (__ia64__) && defined (__VMS__) - -#include "tb-ivms.c" - -#elif defined (_WIN64) && defined (__SEH__) +#if defined (_WIN64) && defined (__SEH__) #include diff --git a/main/gcc/ada/tree_io.adb b/main/gcc/ada/tree_io.adb index 6f564782345..addefd09b08 100644 --- a/main/gcc/ada/tree_io.adb +++ b/main/gcc/ada/tree_io.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/treepr.adb b/main/gcc/ada/treepr.adb index 5bc09a7130f..0f21b9973c0 100644 --- a/main/gcc/ada/treepr.adb +++ b/main/gcc/ada/treepr.adb @@ -236,14 +236,17 @@ package body Treepr is end case; end p; + --------- + -- par -- + --------- + + function par (N : Union_Id) return Node_Or_Entity_Id renames p; + -------- -- pe -- -------- - procedure pe (E : Elist_Id) is - begin - Print_Tree_Elist (E); - end pe; + procedure pe (N : Union_Id) renames pn; -------- -- pl -- @@ -327,10 +330,13 @@ package body Treepr is -- pp -- -------- - procedure pp (N : Union_Id) is - begin - pn (N); - end pp; + procedure pp (N : Union_Id) renames pn; + + --------- + -- ppp -- + --------- + + procedure ppp (N : Union_Id) renames pt; ---------------- -- Print_Char -- @@ -597,49 +603,18 @@ package body Treepr is begin case M is - when Default_Mechanism - => Write_Str ("Default"); - when By_Copy - => Write_Str ("By_Copy"); - when By_Reference - => Write_Str ("By_Reference"); - when By_Descriptor - => Write_Str ("By_Descriptor"); - when By_Descriptor_UBS - => Write_Str ("By_Descriptor_UBS"); - when By_Descriptor_UBSB - => Write_Str ("By_Descriptor_UBSB"); - when By_Descriptor_UBA - => Write_Str ("By_Descriptor_UBA"); - when By_Descriptor_S - => Write_Str ("By_Descriptor_S"); - when By_Descriptor_SB - => Write_Str ("By_Descriptor_SB"); - when By_Descriptor_A - => Write_Str ("By_Descriptor_A"); - when By_Descriptor_NCA - => Write_Str ("By_Descriptor_NCA"); - when By_Short_Descriptor - => Write_Str ("By_Short_Descriptor"); - when By_Short_Descriptor_UBS - => Write_Str ("By_Short_Descriptor_UBS"); - when By_Short_Descriptor_UBSB - => Write_Str ("By_Short_Descriptor_UBSB"); - when By_Short_Descriptor_UBA - => Write_Str ("By_Short_Descriptor_UBA"); - when By_Short_Descriptor_S - => Write_Str ("By_Short_Descriptor_S"); - when By_Short_Descriptor_SB - => Write_Str ("By_Short_Descriptor_SB"); - when By_Short_Descriptor_A - => Write_Str ("By_Short_Descriptor_A"); - when By_Short_Descriptor_NCA - => Write_Str ("By_Short_Descriptor_NCA"); + when Default_Mechanism => + Write_Str ("Default"); + + when By_Copy => + Write_Str ("By_Copy"); + + when By_Reference => + Write_Str ("By_Reference"); when 1 .. Mechanism_Type'Last => Write_Str ("By_Copy if size <= "); Write_Int (Int (M)); - end case; end; @@ -1583,20 +1558,20 @@ package body Treepr is -- pt -- -------- - procedure pt (N : Node_Id) is + procedure pt (N : Union_Id) is begin - Print_Node_Subtree (N); + 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; end pt; - --------- - -- ppp -- - --------- - - procedure ppp (N : Node_Id) is - begin - pt (N); - end ppp; - ------------------- -- Serial_Number -- ------------------- diff --git a/main/gcc/ada/treepr.ads b/main/gcc/ada/treepr.ads index 2d1fb93e8e0..6ba58d6b2b2 100644 --- a/main/gcc/ada/treepr.ads +++ b/main/gcc/ada/treepr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,33 +60,36 @@ package Treepr is -- Prints the subtree consisting of the given element list and all its -- referenced descendants. - -- The following debugging procedures are intended to be called from gdb + -- The following debugging procedures are intended to be called from gdb. + -- Note that in several cases there are synonyms which represent historical + -- development, and we keep them because some people are used to them! - function p (N : Union_Id) return Node_Or_Entity_Id; + function p (N : Union_Id) return Node_Or_Entity_Id; + function par (N : Union_Id) return Node_Or_Entity_Id; pragma Export (Ada, p); - -- Returns parent of a list or node (depending on the value of N). If N + pragma Export (Ada, par); + -- Return parent of a list or node (depending on the value of N). If N -- is neither a list nor a node id, then prints a message to that effect -- and returns Empty. procedure pn (N : Union_Id); - -- Prints a node, node list, uint, or anything else that falls under - -- the definition of Union_Id. Historically this was only for printing - -- nodes, hence the name. - procedure pp (N : Union_Id); + procedure pe (N : Union_Id); + pragma Export (Ada, pn); pragma Export (Ada, pp); - -- Identical to pn, present for historical reasons + pragma Export (Ada, pe); + -- Print a node, node list, uint, or anything else that falls under + -- the definition of Union_Id. Historically this was only for printing + -- nodes, hence the name. - procedure ppp (N : Node_Id); + procedure pt (N : Union_Id); + procedure ppp (N : Union_Id); + pragma Export (Ada, pt); pragma Export (Ada, ppp); - -- Same as Print_Node_Subtree - - -- The following are no longer really needed, now that pn will print - -- anything you throw at it. - - procedure pe (E : Elist_Id); - pragma Export (Ada, pe); - -- Same as Print_Tree_Elist + -- Same as pn/pp, except prints subtrees. For Nodes, it is exactly the same + -- as Print_Node_Subtree. For Elists it is the same as Print_Elist_Subtree. + -- For Lists, it is the same as Print_Tree_List. If given anything other + -- than a Node, List, or Elist, same effect as pn. procedure pl (L : Int); pragma Export (Ada, pl); @@ -95,8 +98,4 @@ package Treepr is -- on the left and add a minus sign. This just saves some typing in the -- debugger. - procedure pt (N : Node_Id); - pragma Export (Ada, pt); - -- Same as ppp - end Treepr; diff --git a/main/gcc/ada/types.adb b/main/gcc/ada/types.adb index bcb1922ad06..67d15cff621 100644 --- a/main/gcc/ada/types.adb +++ b/main/gcc/ada/types.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/types.ads b/main/gcc/ada/types.ads index 46fb714ee57..d723248821e 100644 --- a/main/gcc/ada/types.ads +++ b/main/gcc/ada/types.ads @@ -795,10 +795,16 @@ package Types is -- mechanism. See specification of Sem_Mech for full details. The following -- subtype is used to represent values of this type: - subtype Mechanism_Type is Int range -18 .. Int'Last; + subtype Mechanism_Type is Int range -2 .. Int'Last; -- Type used to represent a mechanism value. This is a subtype rather than -- a type to avoid some annoying processing problems with certain routines - -- in Einfo (processing them to create the corresponding C). + -- in Einfo (processing them to create the corresponding C). The values in + -- the range -2 .. 0 are used to represent mechanism types declared as + -- named constants in the spec of Sem_Mech. Positive values are used for + -- the case of a pragma C_Pass_By_Copy that sets a threshold value for the + -- mechanism to be used. For example if pragma C_Pass_By_Copy (32) is given + -- then Default_C_Record_Mechanism is set to 32, and the meaning is to use + -- By_Reference if the size is greater than 32, and By_Copy otherwise. ------------------------------ -- Run-Time Exception Codes -- @@ -820,18 +826,30 @@ package Types is -- To add a new code, you need to do the following: - -- 1. Modify the type and subtype declarations below appropriately, - -- keeping things in alphabetical order. + -- 1. Assign a new number to the reason. Do not renumber existing codes, + -- since this causes compatibility/bootstrap issues, and problems in + -- the CIL/JVM backends. So always add the new code at the end of the + -- list. - -- 2. Modify the corresponding definitions in types.h, including the + -- 2. Update the contents of the array Kind + + -- 3. Modify the corresponding definitions in types.h, including the -- definition of last_reason_code. - -- 3. Add the name of the routines in exp_ch11.Get_RT_Exception_Name + -- 4. Add the name of the routines in exp_ch11.Get_RT_Exception_Name - -- 4. Add a new routine in Ada.Exceptions with the appropriate call and + -- 5. Add a new routine in Ada.Exceptions with the appropriate call and -- static string constant. Note that there is more than one version -- of a-except.adb which must be modified. + -- Note on ordering of references. For the tables in Ada.Exceptions units, + -- usually the ordering does not matter, and we use the same ordering as + -- is used here (note the requirement in the ordering here that CE/PE/SE + -- codes be kept together, so the subtype declarations work OK). However, + -- there is an important exception, which is in a-except-2005.adb, where + -- ordering of the Rcheck routines must correspond to the ordering of the + -- Rmsg_xx messages. This is required by the .NET scripts. + type RT_Exception_Code is (CE_Access_Check_Failed, -- 00 CE_Access_Parameter_Is_Null, -- 01 @@ -843,17 +861,18 @@ package Types is CE_Length_Check_Failed, -- 07 CE_Null_Exception_Id, -- 08 CE_Null_Not_Allowed, -- 09 + CE_Overflow_Check_Failed, -- 10 CE_Partition_Check_Failed, -- 11 CE_Range_Check_Failed, -- 12 CE_Tag_Check_Failed, -- 13 - PE_Access_Before_Elaboration, -- 14 PE_Accessibility_Check_Failed, -- 15 PE_Address_Of_Intrinsic, -- 16 PE_Aliased_Parameters, -- 17 PE_All_Guards_Closed, -- 18 PE_Bad_Predicated_Generic_Type, -- 19 + PE_Current_Task_In_Entry_Body, -- 20 PE_Duplicated_Entry_Address, -- 21 PE_Explicit_Raise, -- 22 @@ -864,24 +883,60 @@ package Types is PE_Overlaid_Controlled_Object, -- 27 PE_Potentially_Blocking_Operation, -- 28 PE_Stubbed_Subprogram_Called, -- 29 + PE_Unchecked_Union_Restriction, -- 30 PE_Non_Transportable_Actual, -- 31 - SE_Empty_Storage_Pool, -- 32 SE_Explicit_Raise, -- 33 SE_Infinite_Recursion, -- 34 - SE_Object_Too_Large); -- 35 - - subtype RT_CE_Exceptions is RT_Exception_Code range - CE_Access_Check_Failed .. - CE_Tag_Check_Failed; - - subtype RT_PE_Exceptions is RT_Exception_Code range - PE_Access_Before_Elaboration .. - PE_Non_Transportable_Actual; - - subtype RT_SE_Exceptions is RT_Exception_Code range - SE_Empty_Storage_Pool .. - SE_Object_Too_Large; + SE_Object_Too_Large, -- 35 + PE_Stream_Operation_Not_Allowed); -- 36 + + Last_Reason_Code : constant := 36; + -- Last reason code + + type Reason_Kind is (CE_Reason, PE_Reason, SE_Reason); + -- Categorization of reason codes by exception raised + + Rkind : array (RT_Exception_Code range <>) of Reason_Kind := + (CE_Access_Check_Failed => CE_Reason, + CE_Access_Parameter_Is_Null => CE_Reason, + CE_Discriminant_Check_Failed => CE_Reason, + CE_Divide_By_Zero => CE_Reason, + CE_Explicit_Raise => CE_Reason, + CE_Index_Check_Failed => CE_Reason, + CE_Invalid_Data => CE_Reason, + CE_Length_Check_Failed => CE_Reason, + CE_Null_Exception_Id => CE_Reason, + CE_Null_Not_Allowed => CE_Reason, + CE_Overflow_Check_Failed => CE_Reason, + CE_Partition_Check_Failed => CE_Reason, + CE_Range_Check_Failed => CE_Reason, + CE_Tag_Check_Failed => CE_Reason, + + PE_Access_Before_Elaboration => PE_Reason, + PE_Accessibility_Check_Failed => PE_Reason, + PE_Address_Of_Intrinsic => PE_Reason, + PE_Aliased_Parameters => PE_Reason, + PE_All_Guards_Closed => PE_Reason, + PE_Bad_Predicated_Generic_Type => PE_Reason, + PE_Current_Task_In_Entry_Body => PE_Reason, + PE_Duplicated_Entry_Address => PE_Reason, + PE_Explicit_Raise => PE_Reason, + PE_Finalize_Raised_Exception => PE_Reason, + PE_Implicit_Return => PE_Reason, + PE_Misaligned_Address_Value => PE_Reason, + PE_Missing_Return => PE_Reason, + PE_Overlaid_Controlled_Object => PE_Reason, + PE_Potentially_Blocking_Operation => PE_Reason, + PE_Stubbed_Subprogram_Called => PE_Reason, + PE_Unchecked_Union_Restriction => PE_Reason, + PE_Non_Transportable_Actual => PE_Reason, + PE_Stream_Operation_Not_Allowed => PE_Reason, + + SE_Empty_Storage_Pool => SE_Reason, + SE_Explicit_Raise => SE_Reason, + SE_Infinite_Recursion => SE_Reason, + SE_Object_Too_Large => SE_Reason); end Types; diff --git a/main/gcc/ada/types.h b/main/gcc/ada/types.h index dc3f82fec31..949065c2c80 100644 --- a/main/gcc/ada/types.h +++ b/main/gcc/ada/types.h @@ -383,15 +383,16 @@ typedef Int Mechanism_Type; #define PE_Implicit_Return 24 #define PE_Misaligned_Address_Value 25 #define PE_Missing_Return 26 +#define PE_Non_Transportable_Actual 31 #define PE_Overlaid_Controlled_Object 27 #define PE_Potentially_Blocking_Operation 28 +#define PE_Stream_Operation_Not_Allowed 36 #define PE_Stubbed_Subprogram_Called 29 #define PE_Unchecked_Union_Restriction 30 -#define PE_Non_Transportable_Actual 31 #define SE_Empty_Storage_Pool 32 #define SE_Explicit_Raise 33 #define SE_Infinite_Recursion 34 #define SE_Object_Too_Large 35 -#define LAST_REASON_CODE 35 +#define LAST_REASON_CODE 36 diff --git a/main/gcc/ada/ug_words b/main/gcc/ada/ug_words deleted file mode 100644 index 48a36b791c5..00000000000 --- a/main/gcc/ada/ug_words +++ /dev/null @@ -1,271 +0,0 @@ -b_ ^ B_ -b~ ^ B__ -cc1 ^ CC1 -Cc1 ^ CC1 -emacs ^ EMACS -Emacs ^ EMACS -gdb ^ GDB -Gdb ^ GDB -gnat1 ^ GNAT1 -Gnat1 ^ GNAT1 -gnatbind ^ GNAT BIND -Gnatbind ^ GNAT BIND -gnatcheck ^ GNAT CHECK -Gnatcheck ^ GNAT CHECK -gnatchop ^ GNAT CHOP -Gnatchop ^ GNAT CHOP -gnatclean ^ GNAT CLEAN -Gnatclean ^ GNAT CLEAN -gnatelim ^ GNAT ELIM -Gnatelim ^ GNAT ELIM -gnatf ^ GNAT XREF -Gnatf ^ GNAT XREF -gnatfind ^ GNAT FIND -Gnatfind ^ GNAT FIND -gnatkr ^ GNAT KRUNCH -Gnatkr ^ GNAT KRUNCH -gnatlink ^ GNAT LINK -Gnatlink ^ GNAT LINK -gnatls ^ GNAT LIST -Gnatls ^ GNAT LIST -gnatmake ^ GNAT MAKE -Gnatmake ^ GNAT MAKE -gnatmetric ^ GNAT METRIC -Gnatmetric ^ GNAT METRIC -gnatname ^ GNAT NAME -Gnatname ^ GNAT NAME -gnatpp ^ GNAT PRETTY -Gnatpp ^ GNAT PRETTY -gnatprep ^ GNAT PREPROCESS -Gnatprep ^ GNAT PREPROCESS -gnatstub ^ GNAT STUB -Gnatstub ^ GNAT STUB -gnatxref ^ GNAT XREF -Gnatxref ^ GNAT XREF -gcc ^ GNAT COMPILE -gcc -c ^ GNAT COMPILE --fno-inline ^ /INLINE=SUPPRESS --fstack-check ^ /CHECKS=STACK --fno-strict-aliasing ^ /OPTIMIZE=NO_STRICT_ALIASING --gnata ^ /CHECKS=ASSERTIONS --gnatA ^ /NO_GNAT_ADC --gnatb ^ /REPORT_ERRORS=BRIEF --gnatB ^ /ASSUME_VALID --gnatc ^ /NOLOAD --gnatct ^ /NOLOAD /TREE_OUTPUT --gnatdc ^ /TRACE_UNITS --gnatdO ^ /REPORT_ERRORS=IMMEDIATE --gnatC ^ /COMPRESS_NAMES --gnatDG ^ /XDEBUG /EXPAND_SOURCEA --gnatD ^ /XDEBUG --gnateA ^ /ALIASING_CHECK --gnatec ^ /CONFIGURATION_PRAGMAS_FILE --gnated ^ /DISABLE_ATOMIC_SYNCHRONIZATION --gnateD ^ /SYMBOL_PREPROCESSING --gnateE ^ /EXTRA_EXCEPTION_INFORMATION --gnatef ^ /FULL_PATH_IN_BRIEF_MESSAGES --gnateF ^ /FLOAT_OVERFLOW_CHECK --gnateG ^ /GENERATE_PROCESSED_SOURCE --gnatei ^ /MAX_INSTANTIATIONS= --gnateI ^ /MULTI_UNIT_INDEX= --gnatel ^ /ELABORATION_INFO_MESSAGES --gnateL ^ /NOELABORATION_INFO_MESSAGES --gnatem ^ /MAPPING_FILE --gnatep ^ /DATA_PREPROCESSING --gnateP ^ /CATEGORIZATION_WARNINGS --gnateS ^ /SCO_OUTPUT --gnatet ^ /WRITE_TARGET_DEPENDENT_INFO --gnateT ^ /READ_TARGET_DEPENDENT_INFO --gnateu ^ /IGNORE_UNRECOGNIZED --gnateV ^ /PARAMETER_VALIDITY_CHECK --gnateY ^ /IGNORE_STYLE_CHECKS_PRAGMAS --gnatE ^ /CHECKS=ELABORATION --gnatf ^ /REPORT_ERRORS=FULL --gnatF ^ /UPPERCASE_EXTERNALS --gnatg ^ /STYLE_CHECKS=GNAT --gnatG ^ /EXPAND_SOURCE --gnatk ^ /FILE_NAME_MAX_LENGTH --gnatl ^ /LIST --gnatL ^ /LONGJMP_SETJMP --gnatj ^ /JUSTIFY_MESSAGES --gnatj0 ^ /NO_JUSTIFY_MESSAGES --gnatjnn ^ /JUSTIFY_MESSAGES=nn --gnatL ^ /INTERSPERSE_SOURCE --gnatm ^ /ERROR_LIMIT --gnatm2 ^ /ERROR_LIMIT=2 --gnatn ^ /INLINE=PRAGMA --gnatn1 ^ /INLINE=PRAGMA_LEVEL_1 --gnatn2 ^ /INLINE=PRAGMA_LEVEL_2 --gnatN ^ /INLINE=FULL --gnato ^ /CHECKS=OVERFLOW --gnato? ^ /OVERFLOW_CHECKS=? --gnato?? ^ /OVERFLOW_CHECKS=?? --gnatp ^ /CHECKS=SUPPRESS_ALL --gnat-p ^ /CHECKS=UNSUPPRESS_ALL --gnatP ^ /POLLING --gnatR ^ /REPRESENTATION_INFO --gnatR0 ^ /REPRESENTATION_INFO=NONE --gnatR1 ^ /REPRESENTATION_INFO=ARRAYS --gnatR2 ^ /REPRESENTATION_INFO=OBJECTS --gnatR3 ^ /REPRESENTATION_INFO=SYMBOLIC --gnatq ^ /TRY_SEMANTICS --gnatQ ^ /FORCE_ALI --gnatr ^ /TREAT_RESTRICTIONS_AS_WARNINGS --gnats ^ /SYNTAX_ONLY --gnatS ^ /PRINT_STANDARD --gnatt ^ /TREE_OUTPUT --gnatu ^ /UNITS_LIST --gnatU ^ /UNIQUE_ERROR_TAG --gnatv ^ /REPORT_ERRORS=VERBOSE --gnatV ^ /VALIDITY_CHECKING --gnatVa ^ /VALIDITY_CHECKING=ALL --gnatVc ^ /VALIDITY_CHECKING=COPIES --gnatVd ^ /VALIDITY_CHECKING=DEFAULT --gnatVE ^ /VALIDITY_CHECKING=NOCOMPONENTS --gnatVe ^ /VALIDITY_CHECKING=COMPONENTS --gnatVD ^ /VALIDITY_CHECKING=NODEFAULT --gnatVf ^ /VALIDITY_CHECKING=FLOATS --gnatVi ^ /VALIDITY_CHECKING=IN_PARAMS --gnatVm ^ /VALIDITY_CHECKING=MOD_PARAMS --gnatVn ^ /VALIDITY_CHECKING=NONE --gnatVo ^ /VALIDITY_CHECKING=OPERANDS --gnatVp ^ /VALIDITY_CHECKING=PARAMETERS --gnatVr ^ /VALIDITY_CHECKING=RETURNS --gnatVs ^ /VALIDITY_CHECKING=SUBSCRIPTS --gnatVt ^ /VALIDITY_CHECKING=TESTS --gnatw ^ /WARNINGS --gnatwa ^ /WARNINGS=OPTIONAL --gnatwA ^ /WARNINGS=NOOPTIONAL --gnatw.a ^ /WARNINGS=FAILING_ASSERTIONS --gnatw.A ^ /WARNINGS=NO_FAILING_ASSERTIONS --gnatwb ^ /WARNINGS=BAD_FIXED_VALUES --gnatwB ^ /WARNINGS=NO_BAD_FIXED_VALUES --gnatw.b ^ /WARNINGS=BIASED_REPRESENTATION --gnatw.B ^ /WARNINGS=NO_BIASED_REPRESENTATION --gnatwc ^ /WARNINGS=CONDITIONALS --gnatwC ^ /WARNINGS=NOCONDITIONALS --gnatw.c ^ /WARNINGS=MISSING_COMPONENT_CLAUSES --gnatw.C ^ /WARNINGS=NOMISSING_COMPONENT_CLAUSES --gnatw.d ^ /WARNINGS=TAG_WARNINGS --gnatw.D ^ /WARNINGS=NOTAG_WARNINGS --gnatwd ^ /WARNINGS=IMPLICIT_DEREFERENCE --gnatwD ^ /WARNINGS=NOIMPLICIT_DEREFERENCE --gnatwe ^ /WARNINGS=ERRORS --gnatw.e ^ /WARNINGS=EVERY --gnatwf ^ /WARNINGS=UNREFERENCED_FORMALS --gnatwF ^ /WARNINGS=NOUNREFERENCED_FORMALS --gnatwg ^ /WARNINGS=UNRECOGNIZED_PRAGMAS --gnatwG ^ /WARNINGS=NOUNRECOGNIZED_PRAGMAS --gnatwh ^ /WARNINGS=HIDING --gnatwH ^ /WARNINGS=NOHIDING --gnatw.h ^ /WARNINGS=AVOIDGAPS --gnatw.H ^ /WARNINGS=NOAVOIDGAPS --gnatwi ^ /WARNINGS=IMPLEMENTATION --gnatwI ^ /WARNINGS=NOIMPLEMENTATION --gnatw.i ^ /WARNINGS=OVERLAPPING_ACTUALS --gnatw.I ^ /WARNINGS=NOOVERLAPPING_ACTUALS --gnatwj ^ /WARNINGS=OBSOLESCENT --gnatwJ ^ /WARNINGS=NOOBSOLESCENT --gnatwk ^ /WARNINGS=CONSTANT_VARIABLES --gnatwK ^ /WARNINGS=NOCONSTANT_VARIABLES --gnatw.k ^ /WARNINGS=STANDARD_REDEFINITION --gnatw.K ^ /WARNINGS=NOSTANDARD_REDEFINITION --gnatwl ^ /WARNINGS=ELABORATION --gnatwL ^ /WARNINGS=NOELABORATION --gnatwl ^ /WARNINGS=INHERITED_ASPECTS --gnatwL ^ /WARNINGS=NOINHERITED_ASPECTS --gnatwm ^ /WARNINGS=MODIFIED_UNREF --gnatwM ^ /WARNINGS=NOMODIFIED_UNREF --gnatw.m ^ /WARNINGS=SUSPICIOUS_MODULUES --gnatw.M ^ /WARNINGS=NOSUSPICIOUS_MODULUES --gnatwn ^ /WARNINGS=NORMAL --gnatw.n ^ /WARNINGS=ATOMIC_SYNCHRONIZATION --gnatw.N ^ /WARNINGS=NOATOMIC_SYNCHRONIZATION --gnatwo ^ /WARNINGS=OVERLAYS --gnatwO ^ /WARNINGS=NOOVERLAYS --gnatw.o ^ /WARNINGS=OUT_PARAM_UNREF --gnatw.O ^ /WARNINGS=NOOUT_PARAM_UNREF --gnatwp ^ /WARNINGS=INEFFECTIVE_INLINE --gnatwP ^ /WARNINGS=NOINEFFECTIVE_INLINE --gnatw.p ^ /WARNINGS=PARAMETER_ORDER --gnatw.P ^ /WARNINGS=NO_PARAMETER_ORDER --gnatw.h ^ /WARNINGS=OVERRIDING_SIZE --gnatw.H ^ /WARNINGS=NOOVERRIDING_SIZE --gnatw.k ^ /WARNINGS=STANDARD_REDEFINITION --gnatw.K ^ /WARNINGS=NOSTANDARD_REDEFINITION --gnatwq ^ /WARNINGS=MISSING_PARENS --gnatwQ ^ /WARNINGS=NOMISSING_PARENS --gnatwr ^ /WARNINGS=REDUNDANT --gnatwR ^ /WARNINGS=NOREDUNDANT --gnatws ^ /WARNINGS=SUPPRESS --gnatw.s ^ /WARNINGS=OVERRIDING_SIZE --gnatw.S ^ /WARNINGS=NOOVERRIDING_SIZE --gnatwt ^ /WARNINGS=DELETED_CODE --gnatwT ^ /WARNINGS=NODELETED_CODE --gnatw.t ^ /WARNINGS=SUSPICIOUS_CONTRACT --gnatw.T ^ /WARNINGS=NOSUSPICIOUS_CONTRACT --gnatwu ^ /WARNINGS=UNUSED --gnatwU ^ /WARNINGS=NOUNUSED --gnatw.u ^ /WARNINGS=UNORDERED_ENUMERATIONS --gnatw.U ^ /WARNINGS=NOUNORDERED_ENUMERATIONS --gnatwv ^ /WARNINGS=VARIABLES_UNINITIALIZED --gnatwV ^ /WARNINGS=NOVARIABLES_UNINITIALIZED --gnatw.v ^ /WARNINGS=REVERSE_BIT_ORDER --gnatw.V ^ /WARNINGS=NOREVERSE_BIT_ORDER --gnatww ^ /WARNINGS=LOWBOUND_ASSUMED --gnatwW ^ /WARNINGS=NOLOWBOUND_ASSUMED --gnatw.w ^ /WARNINGS=WARNINGS_OFF_PRAGMAS --gnatw.W ^ /WARNINGS=NOWARNINGS_OFF_PRAGMAS --gnatwx ^ /WARNINGS=IMPORT_EXPORT_PRAGMAS --gnatwX ^ /WARNINGS=NOIMPORT_EXPORT_PRAGMAS --gnatw.x ^ /WARNINGS=LOCAL_RAISE_HANDLING --gnatw.X ^ /WARNINGS=NOLOCAL_RAISE_HANDLING --gnatwy ^ /WARNINGS=ADA_COMPATIBILITY --gnatwY ^ /WARNINGS=NOADA_COMPATIBILITY --gnatw.y ^ /WARNINGS=WHY_SPEC_NEEDS_BODY --gnatw.Y ^ /WARNINGS=NOWHY_SPEC_NEEDS_BODY --gnatwz ^ /WARNINGS=UNCHECKED_CONVERSIONS --gnatwZ ^ /WARNINGS=NOUNCHECKED_CONVERSIONS --gnatw.z ^ /WARNINGS=SIZE_ALIGNMENT --gnatw.Z ^ /WARNINGS=NOSIZE_ALIGNMENT --gnatW8 ^ /WIDE_CHARACTER_ENCODING=UTF8 --gnatW? ^ /WIDE_CHARACTER_ENCODING=? --gnaty ^ /STYLE_CHECKS --gnatyO ^ /STYLE_CHECKS=OVERRIDING_INDICATORS --gnatyy ^ /STYLE_CHECKS=ALL_BUILTIN --gnatZ ^ /ZERO_COST_EXCEPTIONS --gnatzc ^ /DISTRIBUTION_STUBS=CALLER --gnatzr ^ /DISTRIBUTION_STUBS=RECEIVER --gnat83 ^ /83 --gnat95 ^ /95 --gnat05 ^ /05 --gnat2005 ^ /2005 --gnat12 ^ /12 --gnat2012 ^ /2012 --gnatx ^ /XREF=SUPPRESS --gnatX ^ /EXTENSIONS_ALLOWED ---RTS ^ /RUNTIME_SYSTEM -switch ^ qualifier -switches ^ qualifiers -Switch ^ Qualifier -Switches ^ Qualifiers -stdout ^ SYS$OUTPUT -stderr ^ SYS$ERROR --bargs ^ /BINDER_QUALIFIERS --cargs ^ /COMPILER_QUALIFIERS --largs ^ /LINKER_QUALIFIERS --margs ^ /MAKE_QUALIFIERS --aIDIR ^ /SOURCE_SEARCH=direc --aODIR ^ /OBJECT_SEARCH=direc --IDIR ^ /SEARCH=direc --nostdinc ^ /NOSTD_INCLUDES --nostdlib ^ /NOSTD_LIBRARIES --pFILE ^ /PROJECT=file --O0 ^ /OPTIMIZE=NONE --O1 ^ /OPTIMIZE=SOME --O2 ^ /OPTIMIZE=ALL --O3 ^ /OPTIMIZE=INLINING --H32 ^ /32_MALLOC --H64 ^ /64_MALLOC --Wall ^ /WARNINGS=ALL_GCC --Wuninitialized ^ /WARNINGS=UNINITIALIZED diff --git a/main/gcc/ada/uname.ads b/main/gcc/ada/uname.ads index c1b59b6cb92..9b38d9a2ec4 100644 --- a/main/gcc/ada/uname.ads +++ b/main/gcc/ada/uname.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/usage.adb b/main/gcc/ada/usage.adb index 806675fc8c3..9cb198f6fc8 100644 --- a/main/gcc/ada/usage.adb +++ b/main/gcc/ada/usage.adb @@ -528,7 +528,7 @@ begin "but not read"); Write_Line (" M* turn off warnings for variable assigned " & "but not read"); - Write_Line (" .m* turn on warnings for suspicious modulus value"); + Write_Line (" .m*+ turn on warnings for suspicious modulus value"); Write_Line (" .M turn off warnings for suspicious modulus value"); Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)"); Write_Line (" .n turn on info messages for atomic " & diff --git a/main/gcc/ada/vms_cmds.ads b/main/gcc/ada/vms_cmds.ads deleted file mode 100644 index f8258af8e3d..00000000000 --- a/main/gcc/ada/vms_cmds.ads +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- V M S _ C M D S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of the GNAT driver. It contains the declaration of --- Command_Type which list all the commands supported by the gnat driver. - -package VMS_Cmds is - type Command_Type is - (Bind, - Chop, - Clean, - Compile, - Check, - Sync, - Elim, - Find, - Krunch, - Link, - List, - Make, - Metric, - Name, - Preprocess, - Pretty, - Shared, - Stack, - Stub, - Test, - Xref, - Undefined); - - subtype Real_Command_Type is Command_Type range Bind .. Xref; - -- All real command types (excludes only Undefined). -end VMS_Cmds; diff --git a/main/gcc/ada/vms_conv.adb b/main/gcc/ada/vms_conv.adb deleted file mode 100644 index fbb19e58b01..00000000000 --- a/main/gcc/ada/vms_conv.adb +++ /dev/null @@ -1,2349 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- V M S _ C O N V -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Gnatvsn; use Gnatvsn; -with Hostparm; -with Opt; -with Osint; use Osint; -with Targparm; use Targparm; - -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Text_IO; use Ada.Text_IO; - -package body VMS_Conv is - - ------------------------- - -- Internal Structures -- - ------------------------- - - -- The switches and commands are defined by strings in the previous - -- section so that they are easy to modify, but internally, they are - -- kept in a more conveniently accessible form described in this - -- section. - - -- Commands, command qualifiers and options have a similar common format - -- so that searching for matching names can be done in a common manner. - - type Item_Id is (Id_Command, Id_Switch, Id_Option); - - type Translation_Type is - ( - T_Direct, - -- A qualifier with no options. - -- Example: GNAT MAKE /VERBOSE - - T_Directories, - -- A qualifier followed by a list of directories - -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR]) - - T_Directory, - -- A qualifier followed by one directory - -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB] - - T_File, - -- A qualifier followed by a filename - -- Example: GNAT LINK /EXECUTABLE=FOO.EXE - - T_No_Space_File, - -- A qualifier followed by a filename - -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR - - T_Numeric, - -- A qualifier followed by a numeric value. - -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39 - - T_String, - -- A qualifier followed by a quoted string. Only used by - -- /IDENTIFICATION qualifier. - -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version" - - T_Options, - -- A qualifier followed by a list of options. - -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS) - - T_Commands, - -- A qualifier followed by a list. Only used for - -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS - -- (gnatmake -cargs -bargs -largs ) - -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ - - T_Other, - -- A qualifier passed directly to the linker. Only used - -- for LINK and SHARED if no other match is found. - -- Example: GNAT LINK FOO.ALI /SYSSHR - - T_Alphanumplus - -- A qualifier followed by a legal linker symbol prefix. Only used - -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz). - -- Example: GNAT BIND /BUILD_LIBRARY=foobar - ); - - type Item (Id : Item_Id); - type Item_Ptr is access all Item; - - type Item (Id : Item_Id) is record - Name : String_Ptr; - -- Name of the command, switch (with slash) or option - - Next : Item_Ptr; - -- Pointer to next item on list, always has the same Id value - - Command : Command_Type := Undefined; - - Unix_String : String_Ptr := null; - -- Corresponding Unix string. For a command, this is the unix command - -- name and possible default switches. For a switch or option it is - -- the unix switch string. - - case Id is - - when Id_Command => - - Switches : Item_Ptr; - -- Pointer to list of switch items for the command, linked - -- through the Next fields with null terminating the list. - - Usage : String_Ptr; - -- Usage information, used only for errors and the default - -- list of commands output. - - Params : Parameter_Ref; - -- Array of parameters - - Defext : String (1 .. 3); - -- Default extension. If non-blank, then this extension is - -- supplied by default as the extension for any file parameter - -- which does not have an extension already. - - when Id_Switch => - - Translation : Translation_Type; - -- Type of switch translation. For all cases, except Options, - -- this is the only field needed, since the Unix translation - -- is found in Unix_String. - - Options : Item_Ptr; - -- For the Options case, this field is set to point to a list - -- of options item (for this case Unix_String is null in the - -- main switch item). The end of the list is marked by null. - - when Id_Option => - - null; - -- No special fields needed, since Name and Unix_String are - -- sufficient to completely described an option. - - end case; - end record; - - subtype Command_Item is Item (Id_Command); - subtype Switch_Item is Item (Id_Switch); - subtype Option_Item is Item (Id_Option); - - Keep_Temps_Option : constant Item_Ptr := - new Item' - (Id => Id_Option, - Name => - new String'("/KEEP_TEMPORARY_FILES"), - Next => null, - Command => Undefined, - Unix_String => null); - - Param_Count : Natural := 0; - -- Number of parameter arguments so far - - Arg_Num : Natural; - -- Argument number - - Arg_File : Ada.Text_IO.File_Type; - -- A file where arguments are read from - - Commands : Item_Ptr; - -- Pointer to head of list of command items, one for each command, with - -- the end of the list marked by a null pointer. - - Last_Command : Item_Ptr; - -- Pointer to last item in Commands list - - Command : Item_Ptr; - -- Pointer to command item for current command - - Make_Commands_Active : Item_Ptr := null; - -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate - -- if a COMMANDS_TRANSLATION switch has been encountered while processing - -- a MAKE Command. - - Output_File_Expected : Boolean := False; - -- True for GNAT LINK after -o switch, so that the ".ali" extension is - -- not added to the executable file name. - - package Buffer is new Table.Table - (Table_Component_Type => Character, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 4096, - Table_Increment => 100, - Table_Name => "Buffer"); - -- Table to store the command to be used - - package Cargs_Buffer is new Table.Table - (Table_Component_Type => Character, - Table_Index_Type => Integer, - Table_Low_Bound => 1, - Table_Initial => 4096, - Table_Increment => 100, - Table_Name => "Cargs_Buffer"); - -- Table to store the compiler switches for GNAT COMPILE - - Cargs : Boolean := False; - -- When True, commands should go to Cargs_Buffer instead of Buffer table - - function Init_Object_Dirs return Argument_List; - -- Get the list of the object directories - - function Invert_Sense (S : String) return VMS_Data.String_Ptr; - -- Given a unix switch string S, computes the inverse (adding or - -- removing ! characters as required), and returns a pointer to - -- the allocated result on the heap. - - function Is_Extensionless (F : String) return Boolean; - -- Returns true if the filename has no extension - - function Match (S1, S2 : String) return Boolean; - -- Determines whether S1 and S2 match (this is a case insensitive match) - - function Match_Prefix (S1, S2 : String) return Boolean; - -- Determines whether S1 matches a prefix of S2. This is also a case - -- insensitive match (for example Match ("AB","abc") is True). - - function Matching_Name - (S : String; - Itm : Item_Ptr; - Quiet : Boolean := False) return Item_Ptr; - -- Determines if the item list headed by Itm and threaded through the - -- Next fields (with null marking the end of the list), contains an - -- entry that uniquely matches the given string. The match is case - -- insensitive and permits unique abbreviation. If the match succeeds, - -- then a pointer to the matching item is returned. Otherwise, an - -- appropriate error message is written. Note that the discriminant - -- of Itm is used to determine the appropriate form of this message. - -- Quiet is normally False as shown, if it is set to True, then no - -- error message is generated in a not found situation (null is still - -- returned to indicate the not-found situation). - - function OK_Alphanumerplus (S : String) return Boolean; - -- Checks that S is a string of alphanumeric characters, - -- returning True if all alphanumeric characters, - -- False if empty or a non-alphanumeric character is present. - - function OK_Integer (S : String) return Boolean; - -- Checks that S is a string of digits, returning True if all digits, - -- False if empty or a non-digit is present. - - procedure Place (C : Character); - -- Place a single character in the buffer, updating Ptr - - procedure Place (S : String); - -- Place a string character in the buffer, updating Ptr - - procedure Place_Lower (S : String); - -- Place string in buffer, forcing letters to lower case, updating Ptr - - procedure Place_Unix_Switches (S : VMS_Data.String_Ptr); - -- Given a unix switch string, place corresponding switches in Buffer, - -- updating Ptr appropriately. Note that in the case of use of ! the - -- result may be to remove a previously placed switch. - - procedure Preprocess_Command_Data; - -- Preprocess the string form of the command and options list into the - -- internal form. - - procedure Process_Argument (The_Command : in out Command_Type); - -- Process one argument from the command line, or one line from - -- from a command line file. For the first call, set The_Command. - - procedure Process_Buffer (S : String); - -- Process the characters in the Buffer table or the Cargs_Buffer table - -- to convert these into arguments. - - procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr); - -- Check that N is a valid command or option name, i.e. that it is of the - -- form of an Ada identifier with upper case letters and underscores. - - procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr); - -- Check that S is a valid switch string as described in the syntax for - -- the switch table item UNIX_SWITCH or else begins with a backquote. - - ---------------------- - -- Init_Object_Dirs -- - ---------------------- - - function Init_Object_Dirs return Argument_List is - Object_Dirs : Integer; - Object_Dir : Argument_List (1 .. 256); - Object_Dir_Name : String_Access; - - begin - Object_Dirs := 0; - Object_Dir_Name := new String'(Object_Dir_Default_Prefix); - Get_Next_Dir_In_Path_Init (Object_Dir_Name); - - loop - declare - Dir : constant String_Access := - Get_Next_Dir_In_Path (Object_Dir_Name); - begin - exit when Dir = null; - Object_Dirs := Object_Dirs + 1; - Object_Dir (Object_Dirs) := - new String'("-L" & - To_Canonical_Dir_Spec - (To_Host_Dir_Spec - (Normalize_Directory_Name (Dir.all).all, - True).all, True).all); - end; - end loop; - - Object_Dirs := Object_Dirs + 1; - Object_Dir (Object_Dirs) := new String'("-lgnat"); - - if OpenVMS_On_Target then - Object_Dirs := Object_Dirs + 1; - Object_Dir (Object_Dirs) := new String'("-ldecgnat"); - end if; - - return Object_Dir (1 .. Object_Dirs); - end Init_Object_Dirs; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Command_List := - (Bind => - (Cname => new S'("BIND"), - Usage => new S'("GNAT BIND file[.ali] /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatbind"), - Unixsws => null, - Switches => Bind_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => "ali"), - - Chop => - (Cname => new S'("CHOP"), - Usage => new S'("GNAT CHOP file [directory] /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatchop"), - Unixsws => null, - Switches => Chop_Switches'Access, - Params => new Parameter_Array'(1 => File, 2 => Optional_File), - Defext => " "), - - Clean => - (Cname => new S'("CLEAN"), - Usage => new S'("GNAT CLEAN /qualifiers files"), - VMS_Only => False, - Unixcmd => new S'("gnatclean"), - Unixsws => null, - Switches => Clean_Switches'Access, - Params => new Parameter_Array'(1 => File), - Defext => " "), - - Compile => - (Cname => new S'("COMPILE"), - Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatmake"), - Unixsws => new Argument_List'(1 => new String'("-f"), - 2 => new String'("-u"), - 3 => new String'("-c")), - Switches => GCC_Switches'Access, - Params => new Parameter_Array'(1 => Files_Or_Wildcard), - Defext => " "), - - Check => - (Cname => new S'("CHECK"), - Usage => new S'("GNAT CHECK name /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatcheck"), - Unixsws => null, - Switches => Check_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Sync => - (Cname => new S'("SYNC"), - Usage => new S'("GNAT SYNC name /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatsync"), - Unixsws => null, - Switches => Sync_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Elim => - (Cname => new S'("ELIM"), - Usage => new S'("GNAT ELIM name /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatelim"), - Unixsws => null, - Switches => Elim_Switches'Access, - Params => new Parameter_Array'(1 => Other_As_Is), - Defext => "ali"), - - Find => - (Cname => new S'("FIND"), - Usage => new S'("GNAT FIND pattern[:sourcefile[:line" - & "[:column]]] filespec[,...] /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatfind"), - Unixsws => null, - Switches => Find_Switches'Access, - Params => new Parameter_Array'(1 => Other_As_Is, - 2 => Files_Or_Wildcard), - Defext => "ali"), - - Krunch => - (Cname => new S'("KRUNCH"), - Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"), - VMS_Only => False, - Unixcmd => new S'("gnatkr"), - Unixsws => null, - Switches => Krunch_Switches'Access, - Params => new Parameter_Array'(1 => File), - Defext => " "), - - Link => - (Cname => new S'("LINK"), - Usage => new S'("GNAT LINK file[.ali]" - & " [extra obj_&_lib_&_exe_&_opt files]" - & " /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatlink"), - Unixsws => null, - Switches => Link_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => "ali"), - - List => - (Cname => new S'("LIST"), - Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"), - VMS_Only => False, - Unixcmd => new S'("gnatls"), - Unixsws => null, - Switches => List_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => "ali"), - - Make => - (Cname => new S'("MAKE"), - Usage => new S'("GNAT MAKE file(s) /qualifiers (includes " - & "COMPILE /qualifiers)"), - VMS_Only => False, - Unixcmd => new S'("gnatmake"), - Unixsws => null, - Switches => Make_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Metric => - (Cname => new S'("METRIC"), - Usage => new S'("GNAT METRIC /qualifiers source_file"), - VMS_Only => False, - Unixcmd => new S'("gnatmetric"), - Unixsws => null, - Switches => Metric_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Name => - (Cname => new S'("NAME"), - Usage => new S'("GNAT NAME /qualifiers naming-pattern " - & "[naming-patterns]"), - VMS_Only => False, - Unixcmd => new S'("gnatname"), - Unixsws => null, - Switches => Name_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_As_Is), - Defext => " "), - - Preprocess => - (Cname => new S'("PREPROCESS"), - Usage => - new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatprep"), - Unixsws => null, - Switches => Prep_Switches'Access, - Params => new Parameter_Array'(1 .. 3 => File), - Defext => " "), - - Pretty => - (Cname => new S'("PRETTY"), - Usage => new S'("GNAT PRETTY /qualifiers source_file"), - VMS_Only => False, - Unixcmd => new S'("gnatpp"), - Unixsws => null, - Switches => Pretty_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Shared => - (Cname => new S'("SHARED"), - Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt" - & "files] /qualifiers"), - VMS_Only => True, - Unixcmd => new S'("gcc"), - Unixsws => - new Argument_List'(new String'("-shared") & Init_Object_Dirs), - Switches => Shared_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Stack => - (Cname => new S'("STACK"), - Usage => new S'("GNAT STACK /qualifiers ci_files"), - VMS_Only => False, - Unixcmd => new S'("gnatstack"), - Unixsws => null, - Switches => Stack_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => "ci" & ASCII.NUL), - - Stub => - (Cname => new S'("STUB"), - Usage => new S'("GNAT STUB file [directory]/qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatstub"), - Unixsws => null, - Switches => Stub_Switches'Access, - Params => new Parameter_Array'(1 => File, 2 => Optional_File), - Defext => " "), - - Test => - (Cname => new S'("TEST"), - Usage => new S'("GNAT TEST file(s) /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnattest"), - Unixsws => null, - Switches => Make_Switches'Access, - Params => new Parameter_Array'(1 => Unlimited_Files), - Defext => " "), - - Xref => - (Cname => new S'("XREF"), - Usage => new S'("GNAT XREF filespec[,...] /qualifiers"), - VMS_Only => False, - Unixcmd => new S'("gnatxref"), - Unixsws => null, - Switches => Xref_Switches'Access, - Params => new Parameter_Array'(1 => Files_Or_Wildcard), - Defext => "ali") - ); - end Initialize; - - ------------------ - -- Invert_Sense -- - ------------------ - - function Invert_Sense (S : String) return VMS_Data.String_Ptr is - Sinv : String (1 .. S'Length * 2); - -- Result (for sure long enough) - - Sinvp : Natural := 0; - -- Pointer to output string - - begin - for Sp in S'Range loop - if Sp = S'First or else S (Sp - 1) = ',' then - if S (Sp) = '!' then - null; - else - Sinv (Sinvp + 1) := '!'; - Sinv (Sinvp + 2) := S (Sp); - Sinvp := Sinvp + 2; - end if; - - else - Sinv (Sinvp + 1) := S (Sp); - Sinvp := Sinvp + 1; - end if; - end loop; - - return new String'(Sinv (1 .. Sinvp)); - end Invert_Sense; - - ---------------------- - -- Is_Extensionless -- - ---------------------- - - function Is_Extensionless (F : String) return Boolean is - begin - for J in reverse F'Range loop - if F (J) = '.' then - return False; - elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then - return True; - end if; - end loop; - - return True; - end Is_Extensionless; - - ----------- - -- Match -- - ----------- - - function Match (S1, S2 : String) return Boolean is - Dif : constant Integer := S2'First - S1'First; - - begin - - if S1'Length /= S2'Length then - return False; - - else - for J in S1'Range loop - if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then - return False; - end if; - end loop; - - return True; - end if; - end Match; - - ------------------ - -- Match_Prefix -- - ------------------ - - function Match_Prefix (S1, S2 : String) return Boolean is - begin - if S1'Length > S2'Length then - return False; - else - return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1)); - end if; - end Match_Prefix; - - ------------------- - -- Matching_Name -- - ------------------- - - function Matching_Name - (S : String; - Itm : Item_Ptr; - Quiet : Boolean := False) return Item_Ptr - is - P1, P2 : Item_Ptr; - - procedure Err; - -- Little procedure to output command/qualifier/option as appropriate - -- and bump error count. - - --------- - -- Err -- - --------- - - procedure Err is - begin - if Quiet then - return; - end if; - - Errors := Errors + 1; - - if Itm /= null then - case Itm.Id is - when Id_Command => - Put (Standard_Error, "command"); - - when Id_Switch => - if Hostparm.OpenVMS then - Put (Standard_Error, "qualifier"); - else - Put (Standard_Error, "switch"); - end if; - - when Id_Option => - Put (Standard_Error, "option"); - - end case; - else - Put (Standard_Error, "input"); - - end if; - - Put (Standard_Error, ": "); - Put (Standard_Error, S); - end Err; - - -- Start of processing for Matching_Name - - begin - -- If exact match, that's the one we want - - P1 := Itm; - while P1 /= null loop - if Match (S, P1.Name.all) then - return P1; - else - P1 := P1.Next; - end if; - end loop; - - -- Now check for prefix matches - - P1 := Itm; - while P1 /= null loop - if P1.Name.all = "/" then - return P1; - - elsif not Match_Prefix (S, P1.Name.all) then - P1 := P1.Next; - - else - -- Here we have found one matching prefix, so see if there is - -- another one (which is an ambiguity) - - P2 := P1.Next; - while P2 /= null loop - if Match_Prefix (S, P2.Name.all) then - if not Quiet then - Put (Standard_Error, "ambiguous "); - Err; - Put (Standard_Error, " (matches "); - Put (Standard_Error, P1.Name.all); - - while P2 /= null loop - if Match_Prefix (S, P2.Name.all) then - Put (Standard_Error, ','); - Put (Standard_Error, P2.Name.all); - end if; - - P2 := P2.Next; - end loop; - - Put_Line (Standard_Error, ")"); - end if; - - return null; - end if; - - P2 := P2.Next; - end loop; - - -- If we fall through that loop, then there was only one match - - return P1; - end if; - end loop; - - -- If we fall through outer loop, there was no match - - if not Quiet then - Put (Standard_Error, "unrecognized "); - Err; - New_Line (Standard_Error); - end if; - - return null; - end Matching_Name; - - ----------------------- - -- OK_Alphanumerplus -- - ----------------------- - - function OK_Alphanumerplus (S : String) return Boolean is - begin - if S'Length = 0 then - return False; - - else - for J in S'Range loop - if not (Is_Alphanumeric (S (J)) or else - S (J) = '_' or else S (J) = '$') - then - return False; - end if; - end loop; - - return True; - end if; - end OK_Alphanumerplus; - - ---------------- - -- OK_Integer -- - ---------------- - - function OK_Integer (S : String) return Boolean is - begin - if S'Length = 0 then - return False; - - else - for J in S'Range loop - if not Is_Digit (S (J)) then - return False; - end if; - end loop; - - return True; - end if; - end OK_Integer; - - -------------------- - -- Output_Version -- - -------------------- - - procedure Output_Version is - begin - if AAMP_On_Target then - Put ("GNAAMP "); - else - Put ("GNAT "); - end if; - - Put_Line (Gnatvsn.Gnat_Version_String); - Put_Line ("Copyright 1996-" & - Current_Year & - ", Free Software Foundation, Inc."); - end Output_Version; - - ----------- - -- Place -- - ----------- - - procedure Place (C : Character) is - begin - if Cargs then - Cargs_Buffer.Append (C); - else - Buffer.Append (C); - end if; - end Place; - - procedure Place (S : String) is - begin - for J in S'Range loop - Place (S (J)); - end loop; - end Place; - - ----------------- - -- Place_Lower -- - ----------------- - - procedure Place_Lower (S : String) is - begin - for J in S'Range loop - Place (To_Lower (S (J))); - end loop; - end Place_Lower; - - ------------------------- - -- Place_Unix_Switches -- - ------------------------- - - procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is - P1, P2, P3 : Natural; - Remove : Boolean; - Slen, Sln2 : Natural; - Wild_Card : Boolean := False; - - begin - P1 := S'First; - while P1 <= S'Last loop - if S (P1) = '!' then - P1 := P1 + 1; - Remove := True; - else - Remove := False; - end if; - - P2 := P1; - pragma Assert (S (P1) = '-' or else S (P1) = '`'); - - while P2 < S'Last and then S (P2 + 1) /= ',' loop - P2 := P2 + 1; - end loop; - - -- Switch is now in S (P1 .. P2) - - Slen := P2 - P1 + 1; - - if Remove then - Wild_Card := S (P2) = '*'; - - if Wild_Card then - Slen := Slen - 1; - P2 := P2 - 1; - end if; - - P3 := 1; - while P3 <= Buffer.Last - Slen loop - if Buffer.Table (P3) = ' ' - and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) = - S (P1 .. P2) - and then (Wild_Card - or else - P3 + Slen = Buffer.Last - or else - Buffer.Table (P3 + Slen + 1) = ' ') - then - Sln2 := Slen; - - if Wild_Card then - while P3 + Sln2 /= Buffer.Last - and then Buffer.Table (P3 + Sln2 + 1) /= ' ' - loop - Sln2 := Sln2 + 1; - end loop; - end if; - - Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) := - Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last); - Buffer.Set_Last (Buffer.Last - Sln2 - 1); - - else - P3 := P3 + 1; - end if; - end loop; - - if Wild_Card then - P2 := P2 + 1; - end if; - - else - pragma Assert (S (P2) /= '*'); - Place (' '); - - if S (P1) = '`' then - P1 := P1 + 1; - end if; - - Place (S (P1 .. P2)); - end if; - - P1 := P2 + 2; - end loop; - end Place_Unix_Switches; - - ----------------------------- - -- Preprocess_Command_Data -- - ----------------------------- - - procedure Preprocess_Command_Data is - begin - for C in Real_Command_Type loop - declare - Command : constant Item_Ptr := new Command_Item; - - Last_Switch : Item_Ptr; - -- Last switch in list - - begin - -- Link new command item into list of commands - - if Last_Command = null then - Commands := Command; - else - Last_Command.Next := Command; - end if; - - Last_Command := Command; - - -- Fill in fields of new command item - - Command.Name := Command_List (C).Cname; - Command.Usage := Command_List (C).Usage; - Command.Command := C; - - if Command_List (C).Unixsws = null then - Command.Unix_String := Command_List (C).Unixcmd; - else - declare - Cmd : String (1 .. 5_000); - Last : Natural := 0; - Sws : constant Argument_List_Access := - Command_List (C).Unixsws; - - begin - Cmd (1 .. Command_List (C).Unixcmd'Length) := - Command_List (C).Unixcmd.all; - Last := Command_List (C).Unixcmd'Length; - - for J in Sws'Range loop - Last := Last + 1; - Cmd (Last) := ' '; - Cmd (Last + 1 .. Last + Sws (J)'Length) := - Sws (J).all; - Last := Last + Sws (J)'Length; - end loop; - - Command.Unix_String := new String'(Cmd (1 .. Last)); - end; - end if; - - Command.Params := Command_List (C).Params; - Command.Defext := Command_List (C).Defext; - - Validate_Command_Or_Option (Command.Name); - - -- Process the switch list - - for S in Command_List (C).Switches'Range loop - declare - SS : constant VMS_Data.String_Ptr := - Command_List (C).Switches (S); - P : Natural := SS'First; - Sw : Item_Ptr := new Switch_Item; - - Last_Opt : Item_Ptr; - -- Pointer to last option - - begin - -- Link new switch item into list of switches - - if Last_Switch = null then - Command.Switches := Sw; - else - Last_Switch.Next := Sw; - end if; - - Last_Switch := Sw; - - -- Process switch string, first get name - - while SS (P) /= ' ' and then SS (P) /= '=' loop - P := P + 1; - end loop; - - Sw.Name := new String'(SS (SS'First .. P - 1)); - - -- Direct translation case - - if SS (P) = ' ' then - Sw.Translation := T_Direct; - Sw.Unix_String := new String'(SS (P + 1 .. SS'Last)); - Validate_Unix_Switch (Sw.Unix_String); - - if SS (P - 1) = '>' then - Sw.Translation := T_Other; - - elsif SS (P + 1) = '`' then - null; - - -- Create the inverted case (/NO ..) - - elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then - Sw := new Switch_Item; - Last_Switch.Next := Sw; - Last_Switch := Sw; - - Sw.Name := - new String'("/NO" & SS (SS'First + 1 .. P - 1)); - Sw.Translation := T_Direct; - Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last)); - Validate_Unix_Switch (Sw.Unix_String); - end if; - - -- Directories translation case - - elsif SS (P + 1) = '*' then - pragma Assert (SS (SS'Last) = '*'); - Sw.Translation := T_Directories; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- Directory translation case - - elsif SS (P + 1) = '%' then - pragma Assert (SS (SS'Last) = '%'); - Sw.Translation := T_Directory; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- File translation case - - elsif SS (P + 1) = '@' then - pragma Assert (SS (SS'Last) = '@'); - Sw.Translation := T_File; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- No space file translation case - - elsif SS (P + 1) = '<' then - pragma Assert (SS (SS'Last) = '>'); - Sw.Translation := T_No_Space_File; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- Numeric translation case - - elsif SS (P + 1) = '#' then - pragma Assert (SS (SS'Last) = '#'); - Sw.Translation := T_Numeric; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- Alphanumerplus translation case - - elsif SS (P + 1) = '|' then - pragma Assert (SS (SS'Last) = '|'); - Sw.Translation := T_Alphanumplus; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- String translation case - - elsif SS (P + 1) = '"' then - pragma Assert (SS (SS'Last) = '"'); - Sw.Translation := T_String; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1)); - Validate_Unix_Switch (Sw.Unix_String); - - -- Commands translation case - - elsif SS (P + 1) = '?' then - Sw.Translation := T_Commands; - Sw.Unix_String := new String'(SS (P + 2 .. SS'Last)); - - -- Options translation case - - else - Sw.Translation := T_Options; - Sw.Unix_String := new String'(""); - - P := P + 1; -- bump past = - while P <= SS'Last loop - declare - Opt : constant Item_Ptr := new Option_Item; - Q : Natural; - - begin - -- Link new option item into options list - - if Last_Opt = null then - Sw.Options := Opt; - else - Last_Opt.Next := Opt; - end if; - - Last_Opt := Opt; - - -- Fill in fields of new option item - - Q := P; - while SS (Q) /= ' ' loop - Q := Q + 1; - end loop; - - Opt.Name := new String'(SS (P .. Q - 1)); - Validate_Command_Or_Option (Opt.Name); - - P := Q + 1; - Q := P; - - while Q <= SS'Last and then SS (Q) /= ' ' loop - Q := Q + 1; - end loop; - - Opt.Unix_String := new String'(SS (P .. Q - 1)); - Validate_Unix_Switch (Opt.Unix_String); - P := Q + 1; - end; - end loop; - end if; - end; - end loop; - end; - end loop; - end Preprocess_Command_Data; - - ---------------------- - -- Process_Argument -- - ---------------------- - - procedure Process_Argument (The_Command : in out Command_Type) is - Argv : String_Access; - Arg_Idx : Integer; - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) return Integer; - -- Begins looking at Arg_Idx + 1 and returns the index of the - -- last character before a slash or else the index of the last - -- character in the string Argv. - - ----------------- - -- Get_Arg_End -- - ----------------- - - function Get_Arg_End - (Argv : String; - Arg_Idx : Integer) return Integer - is - begin - for J in Arg_Idx + 1 .. Argv'Last loop - if Argv (J) = '/' then - return J - 1; - end if; - end loop; - - return Argv'Last; - end Get_Arg_End; - - -- Start of processing for Process_Argument - - begin - Cargs := False; - - -- If an argument file is open, read the next non empty line - - if Is_Open (Arg_File) then - declare - Line : String (1 .. 256); - Last : Natural; - begin - loop - Get_Line (Arg_File, Line, Last); - exit when Last /= 0 or else End_Of_File (Arg_File); - end loop; - - -- If the end of the argument file has been reached, close it - - if End_Of_File (Arg_File) then - Close (Arg_File); - - -- If the last line was empty, return after increasing Arg_Num - -- to go to the next argument on the comment line. - - if Last = 0 then - Arg_Num := Arg_Num + 1; - return; - end if; - end if; - - Argv := new String'(Line (1 .. Last)); - Arg_Idx := 1; - - if Argv (1) = '@' then - Put_Line (Standard_Error, "argument file cannot contain @cmd"); - raise Error_Exit; - end if; - end; - - else - -- No argument file is open, get the argument on the command line - - Argv := new String'(Argument (Arg_Num)); - Arg_Idx := Argv'First; - - -- Check if this is the specification of an argument file - - if Argv (Arg_Idx) = '@' then - -- The first argument on the command line cannot be an argument - -- file. - - if Arg_Num = 1 then - Put_Line - (Standard_Error, - "Cannot specify argument line before command"); - raise Error_Exit; - end if; - - -- Open the file, after conversion of the name to canonical form. - -- Fail if file is not found. - - declare - Canonical_File_Name : String_Access := - To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last)); - begin - Open (Arg_File, In_File, Canonical_File_Name.all); - Free (Canonical_File_Name); - return; - - exception - when others => - Put (Standard_Error, "Cannot open argument file """); - Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last)); - Put_Line (Standard_Error, """"); - raise Error_Exit; - end; - end if; - end if; - - <> - loop - declare - Next_Arg_Idx : Integer; - Arg : String_Access; - - begin - Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - - -- The first one must be a command name - - if Arg_Num = 1 and then Arg_Idx = Argv'First then - Command := Matching_Name (Arg.all, Commands); - - if Command = null then - raise Error_Exit; - end if; - - The_Command := Command.Command; - Output_File_Expected := False; - - -- Give usage information if only command given - - if Argument_Count = 1 - and then Next_Arg_Idx = Argv'Last - then - Output_Version; - New_Line; - Put_Line - ("List of available qualifiers and options"); - New_Line; - - Put (Command.Usage.all); - Set_Col (53); - Put_Line (Command.Unix_String.all); - - declare - Sw : Item_Ptr := Command.Switches; - - begin - while Sw /= null loop - Put (" "); - Put (Sw.Name.all); - - case Sw.Translation is - - when T_Other => - Set_Col (53); - Put_Line (Sw.Unix_String.all & - "/"); - - when T_Direct => - Set_Col (53); - Put_Line (Sw.Unix_String.all); - - when T_Directories => - Put ("=(direc,direc,..direc)"); - Set_Col (53); - Put (Sw.Unix_String.all); - Put (" direc "); - Put (Sw.Unix_String.all); - Put_Line (" direc ..."); - - when T_Directory => - Put ("=directory"); - Set_Col (53); - Put (Sw.Unix_String.all); - - if Sw.Unix_String (Sw.Unix_String'Last) - /= '=' - then - Put (' '); - end if; - - Put_Line ("directory "); - - when T_File | T_No_Space_File => - Put ("=file"); - Set_Col (53); - Put (Sw.Unix_String.all); - - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Put (' '); - end if; - - Put_Line ("file "); - - when T_Numeric => - Put ("=nnn"); - Set_Col (53); - - if Sw.Unix_String - (Sw.Unix_String'First) = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; - - Put_Line ("nnn"); - - when T_Alphanumplus => - Put ("=xyz"); - Set_Col (53); - - if Sw.Unix_String - (Sw.Unix_String'First) = '`' - then - Put (Sw.Unix_String - (Sw.Unix_String'First + 1 - .. Sw.Unix_String'Last)); - else - Put (Sw.Unix_String.all); - end if; - - Put_Line ("xyz"); - - when T_String => - Put ("="); - Put ('"'); - Put (""); - Put ('"'); - Set_Col (53); - - Put (Sw.Unix_String.all); - - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Put (' '); - end if; - - Put (""); - New_Line; - - when T_Commands => - Put (" (switches for "); - Put (Sw.Unix_String - (Sw.Unix_String'First + 7 - .. Sw.Unix_String'Last)); - Put (')'); - Set_Col (53); - Put (Sw.Unix_String - (Sw.Unix_String'First - .. Sw.Unix_String'First + 5)); - Put_Line (" switches"); - - when T_Options => - declare - Opt : Item_Ptr := Sw.Options; - - begin - Put_Line ("=(option,option..)"); - - while Opt /= null loop - Put (" "); - Put (Opt.Name.all); - - if Opt = Sw.Options then - Put (" (D)"); - end if; - - Set_Col (53); - Put_Line (Opt.Unix_String.all); - Opt := Opt.Next; - end loop; - end; - - end case; - - Sw := Sw.Next; - end loop; - end; - - raise Normal_Exit; - end if; - - -- Special handling for internal debugging switch /? - - elsif Arg.all = "/?" then - Display_Command := True; - Output_File_Expected := False; - - -- Special handling of internal option /KEEP_TEMPORARY_FILES - - elsif Arg'Length >= 7 - and then Matching_Name - (Arg.all, Keep_Temps_Option, True) /= null - then - Opt.Keep_Temporary_Files := True; - - -- Copy -switch unchanged, as well as +rule - - elsif Arg (Arg'First) = '-' or else Arg (Arg'First) = '+' then - Place (' '); - Place (Arg.all); - - -- Set Output_File_Expected for the next argument - - Output_File_Expected := - Arg.all = "-o" and then The_Command = Link; - - -- Copy quoted switch with quotes stripped - - elsif Arg (Arg'First) = '"' then - if Arg (Arg'Last) /= '"' then - Put (Standard_Error, "misquoted argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - - else - Place (' '); - Place (Arg (Arg'First + 1 .. Arg'Last - 1)); - end if; - - Output_File_Expected := False; - - -- Parameter Argument - - elsif Arg (Arg'First) /= '/' - and then Make_Commands_Active = null - then - Param_Count := Param_Count + 1; - - if Param_Count <= Command.Params'Length then - - case Command.Params (Param_Count) is - - when File | Optional_File => - declare - Normal_File : constant String_Access := - To_Canonical_File_Spec - (Arg.all); - - begin - Place (' '); - Place_Lower (Normal_File.all); - - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - end; - - when Unlimited_Files => - declare - Normal_File : constant String_Access := - To_Canonical_File_Spec - (Arg.all); - - File_Is_Wild : Boolean := False; - File_List : String_Access_List_Access; - - begin - for J in Arg'Range loop - if Arg (J) = '*' - or else Arg (J) = '%' - then - File_Is_Wild := True; - end if; - end loop; - - if File_Is_Wild then - File_List := To_Canonical_File_List - (Arg.all, False); - - for J in File_List.all'Range loop - Place (' '); - Place_Lower (File_List.all (J).all); - end loop; - - else - Place (' '); - Place_Lower (Normal_File.all); - - -- Add extension if not present, except after - -- switch -o. - - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - and then not Output_File_Expected - then - Place ('.'); - Place (Command.Defext); - end if; - end if; - - Param_Count := Param_Count - 1; - end; - - when Other_As_Is => - Place (' '); - Place (Arg.all); - - when Unlimited_As_Is => - Place (' '); - Place (Arg.all); - Param_Count := Param_Count - 1; - - when Files_Or_Wildcard => - - -- Remove spaces from a comma separated list - -- of file names and adjust control variables - -- accordingly. - - while Arg_Num < Argument_Count and then - (Argv (Argv'Last) = ',' xor - Argument (Arg_Num + 1) - (Argument (Arg_Num + 1)'First) = ',') - loop - Argv := new String' - (Argv.all & Argument (Arg_Num + 1)); - Arg_Num := Arg_Num + 1; - Arg_Idx := Argv'First; - Next_Arg_Idx := - Get_Arg_End (Argv.all, Arg_Idx); - Arg := new String' - (Argv (Arg_Idx .. Next_Arg_Idx)); - end loop; - - -- Parse the comma separated list of VMS - -- filenames and place them on the command - -- line as space separated Unix style - -- filenames. Lower case and add default - -- extension as appropriate. - - declare - Arg1_Idx : Integer := Arg'First; - - function Get_Arg1_End - (Arg : String; - Arg_Idx : Integer) return Integer; - -- Begins looking at Arg_Idx + 1 and - -- returns the index of the last character - -- before a comma or else the index of the - -- last character in the string Arg. - - ------------------ - -- Get_Arg1_End -- - ------------------ - - function Get_Arg1_End - (Arg : String; - Arg_Idx : Integer) return Integer - is - begin - for J in Arg_Idx + 1 .. Arg'Last loop - if Arg (J) = ',' then - return J - 1; - end if; - end loop; - - return Arg'Last; - end Get_Arg1_End; - - begin - loop - declare - Next_Arg1_Idx : - constant Integer := - Get_Arg1_End (Arg.all, Arg1_Idx); - - Arg1 : - constant String := - Arg (Arg1_Idx .. Next_Arg1_Idx); - - Normal_File : - constant String_Access := - To_Canonical_File_Spec (Arg1); - - begin - Place (' '); - Place_Lower (Normal_File.all); - - if Is_Extensionless (Normal_File.all) - and then Command.Defext /= " " - then - Place ('.'); - Place (Command.Defext); - end if; - - Arg1_Idx := Next_Arg1_Idx + 1; - end; - - exit when Arg1_Idx > Arg'Last; - - -- Don't allow two or more commas in - -- a row - - if Arg (Arg1_Idx) = ',' then - Arg1_Idx := Arg1_Idx + 1; - if Arg1_Idx > Arg'Last or else - Arg (Arg1_Idx) = ',' - then - Put_Line - (Standard_Error, - "Malformed Parameter: " & - Arg.all); - Put (Standard_Error, "usage: "); - Put_Line (Standard_Error, - Command.Usage.all); - raise Error_Exit; - end if; - end if; - - end loop; - end; - end case; - end if; - - -- Reset Output_File_Expected, in case it was True - - Output_File_Expected := False; - - -- Qualifier argument - - else - Output_File_Expected := False; - - Cargs := Command.Name.all = "COMPILE"; - - -- This code is too heavily nested, should be - -- separated out as separate subprogram ??? - - declare - Sw : Item_Ptr; - SwP : Natural; - P2 : Natural; - Endp : Natural := 0; -- avoid warning - Opt : Item_Ptr; - - begin - SwP := Arg'First; - while SwP < Arg'Last - and then Arg (SwP + 1) /= '=' - loop - SwP := SwP + 1; - end loop; - - -- At this point, the switch name is in - -- Arg (Arg'First..SwP) and if that is not the - -- whole switch, then there is an equal sign at - -- Arg (SwP + 1) and the rest of Arg is what comes - -- after the equal sign. - - -- If make commands are active, see if we have - -- another COMMANDS_TRANSLATION switch belonging - -- to gnatmake. - - if Make_Commands_Active /= null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); - - if Sw /= null - and then Sw.Translation = T_Commands - then - null; - - else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Make_Commands_Active.Switches, - Quiet => False); - end if; - - -- For case of GNAT MAKE or CHOP, if we cannot - -- find the switch, then see if it is a - -- recognized compiler switch instead, and if - -- so process the compiler switch. - - elsif Command.Name.all = "MAKE" - or else - Command.Name.all = "CHOP" - then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => True); - - if Sw = null then - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Matching_Name - ("COMPILE", Commands).Switches, - Quiet => False); - end if; - - -- For all other cases, just search the relevant - -- command. - - else - Sw := - Matching_Name - (Arg (Arg'First .. SwP), - Command.Switches, - Quiet => False); - - -- Special case for GNAT COMPILE /UNCHECKED... - -- because the corresponding switch --unchecked... is - -- for gnatmake, not for the compiler. - - if Cargs - and then Sw.Name.all = "/UNCHECKED_SHARED_LIB_IMPORTS" - then - Cargs := False; - end if; - end if; - - if Sw /= null then - if Cargs - and then Sw.Name /= null - and then - (Sw.Name.all = "/PROJECT_FILE" or else - Sw.Name.all = "/MESSAGES_PROJECT_FILE" or else - Sw.Name.all = "/EXTERNAL_REFERENCE") - then - Cargs := False; - end if; - - case Sw.Translation is - when T_Direct => - Place_Unix_Switches (Sw.Unix_String); - - if SwP < Arg'Last - and then Arg (SwP + 1) = '=' - then - Put (Standard_Error, - "qualifier options ignored: "); - Put_Line (Standard_Error, Arg.all); - end if; - - when T_Directories => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directories for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; - - elsif Arg (Arg'Last) /= ')' then - - -- Remove spaces from a comma separated - -- list of file names and adjust - -- control variables accordingly. - - if Arg_Num < Argument_Count and then - (Argv (Argv'Last) = ',' xor - Argument (Arg_Num + 1) - (Argument (Arg_Num + 1)'First) = ',') - then - Argv := - new String'(Argv.all - & Argument - (Arg_Num + 1)); - Arg_Num := Arg_Num + 1; - Arg_Idx := Argv'First; - Next_Arg_Idx := - Get_Arg_End (Argv.all, Arg_Idx); - Arg := - new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - goto Tryagain_After_Coalesce; - end if; - - Put (Standard_Error, - "incorrectly parenthesized " & - "or malformed argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; - - while SwP <= Endp loop - declare - Dir_Is_Wild : Boolean := False; - Dir_Maybe_Is_Wild : Boolean := False; - - Dir_List : String_Access_List_Access; - - begin - P2 := SwP; - - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - -- A wildcard directory spec on VMS will - -- contain either * or % or ... - - if Arg (P2) = '*' then - Dir_Is_Wild := True; - - elsif Arg (P2) = '%' then - Dir_Is_Wild := True; - - elsif Dir_Maybe_Is_Wild - and then Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Is_Wild := True; - Dir_Maybe_Is_Wild := False; - - elsif Dir_Maybe_Is_Wild then - Dir_Maybe_Is_Wild := False; - - elsif Arg (P2) = '.' - and then Arg (P2 + 1) = '.' - then - Dir_Maybe_Is_Wild := True; - - end if; - - P2 := P2 + 1; - end loop; - - if Dir_Is_Wild then - Dir_List := - To_Canonical_File_List - (Arg (SwP .. P2), True); - - for J in Dir_List.all'Range loop - Place_Unix_Switches (Sw.Unix_String); - Place_Lower (Dir_List.all (J).all); - end loop; - - else - Place_Unix_Switches (Sw.Unix_String); - Place_Lower - (To_Canonical_Dir_Spec - (Arg (SwP .. P2), False).all); - end if; - - SwP := P2 + 2; - end; - end loop; - - when T_Directory => - if SwP + 1 > Arg'Last then - Put (Standard_Error, - "missing directory for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - - else - Place_Unix_Switches (Sw.Unix_String); - - -- Some switches end in "=", no space here - - if Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; - - Place_Lower - (To_Canonical_Dir_Spec - (Arg (SwP + 2 .. Arg'Last), False).all); - end if; - - when T_File | T_No_Space_File => - if SwP + 2 > Arg'Last then - Put (Standard_Error, "missing file for: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - - else - Place_Unix_Switches (Sw.Unix_String); - - -- Some switches end in "=", no space here. - - if Sw.Translation = T_File - and then Sw.Unix_String - (Sw.Unix_String'Last) /= '=' - then - Place (' '); - end if; - - Place_Lower - (To_Canonical_File_Spec - (Arg (SwP + 2 .. Arg'Last)).all); - end if; - - when T_Numeric => - if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); - - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, " must be numeric"); - Errors := Errors + 1; - end if; - - when T_Alphanumplus => - if OK_Alphanumerplus - (Arg (SwP + 2 .. Arg'Last)) - then - Place_Unix_Switches (Sw.Unix_String); - Place (Arg (SwP + 2 .. Arg'Last)); - - else - Put (Standard_Error, "argument for "); - Put (Standard_Error, Sw.Name.all); - Put_Line (Standard_Error, - " must be alphanumeric"); - Errors := Errors + 1; - end if; - - when T_String => - - -- A String value must be extended to the end of - -- the Argv, otherwise strings like "foo/bar" get - -- split at the slash. - - -- The beginning and ending of the string are - -- flagged with embedded nulls which are removed - -- when building the Spawn call. Nulls are use - -- because they won't show up in a /? output. - -- Quotes aren't used because that would make it - -- difficult to embed them. - - Place_Unix_Switches (Sw.Unix_String); - - if Next_Arg_Idx /= Argv'Last then - Next_Arg_Idx := Argv'Last; - Arg := - new String'(Argv (Arg_Idx .. Next_Arg_Idx)); - - SwP := Arg'First; - while SwP < Arg'Last - and then Arg (SwP + 1) /= '=' - loop - SwP := SwP + 1; - end loop; - end if; - - Place (ASCII.NUL); - Place (Arg (SwP + 2 .. Arg'Last)); - Place (ASCII.NUL); - - when T_Commands => - - -- Output -largs/-bargs/-cargs - - Place (' '); - Place (Sw.Unix_String - (Sw.Unix_String'First .. - Sw.Unix_String'First + 5)); - - if Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last) = "MAKE" - then - Make_Commands_Active := null; - - else - -- Set source of new commands, also setting this - -- non-null indicates that we are in the special - -- commands mode for processing the -xargs case. - - Make_Commands_Active := - Matching_Name - (Sw.Unix_String - (Sw.Unix_String'First + 7 .. - Sw.Unix_String'Last), - Commands); - end if; - - when T_Options => - if SwP + 1 > Arg'Last then - Place_Unix_Switches (Sw.Options.Unix_String); - SwP := Endp + 1; - - elsif Arg (SwP + 2) /= '(' then - SwP := SwP + 2; - Endp := Arg'Last; - - elsif Arg (Arg'Last) /= ')' then - Put (Standard_Error, - "incorrectly parenthesized argument: "); - Put_Line (Standard_Error, Arg.all); - Errors := Errors + 1; - SwP := Endp + 1; - - else - SwP := SwP + 3; - Endp := Arg'Last - 1; - end if; - - while SwP <= Endp loop - P2 := SwP; - while P2 < Endp - and then Arg (P2 + 1) /= ',' - loop - P2 := P2 + 1; - end loop; - - -- Option name is in Arg (SwP .. P2) - - Opt := Matching_Name (Arg (SwP .. P2), - Sw.Options); - - if Opt /= null then - Place_Unix_Switches (Opt.Unix_String); - end if; - - SwP := P2 + 2; - end loop; - - when T_Other => - Place_Unix_Switches - (new String'(Sw.Unix_String.all & Arg.all)); - - end case; - end if; - end; - end if; - - Arg_Idx := Next_Arg_Idx + 1; - end; - - exit when Arg_Idx > Argv'Last; - - end loop; - - if not Is_Open (Arg_File) then - Arg_Num := Arg_Num + 1; - end if; - end Process_Argument; - - -------------------- - -- Process_Buffer -- - -------------------- - - procedure Process_Buffer (S : String) is - P1, P2 : Natural; - Inside_Nul : Boolean := False; - Arg : String (1 .. 1024); - Arg_Ctr : Natural; - - begin - P1 := 1; - while P1 <= S'Last and then S (P1) = ' ' loop - P1 := P1 + 1; - end loop; - - Arg_Ctr := 1; - Arg (Arg_Ctr) := S (P1); - - while P1 <= S'Last loop - if S (P1) = ASCII.NUL then - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; - - if S (P1) = ' ' and then not Inside_Nul then - P1 := P1 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := S (P1); - - else - Last_Switches.Increment_Last; - P2 := P1; - - while P2 < S'Last - and then (S (P2 + 1) /= ' ' or else - Inside_Nul) - loop - P2 := P2 + 1; - Arg_Ctr := Arg_Ctr + 1; - Arg (Arg_Ctr) := S (P2); - if S (P2) = ASCII.NUL then - Arg_Ctr := Arg_Ctr - 1; - - if Inside_Nul then - Inside_Nul := False; - else - Inside_Nul := True; - end if; - end if; - end loop; - - Last_Switches.Table (Last_Switches.Last) := - new String'(String (Arg (1 .. Arg_Ctr))); - P1 := P2 + 2; - - exit when P1 > S'Last; - - Arg_Ctr := 1; - Arg (Arg_Ctr) := S (P1); - end if; - end loop; - end Process_Buffer; - - -------------------------------- - -- Validate_Command_Or_Option -- - -------------------------------- - - procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is - begin - pragma Assert (N'Length > 0); - - for J in N'Range loop - if N (J) = '_' then - pragma Assert (N (J - 1) /= '_'); - null; - else - pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J))); - null; - end if; - end loop; - end Validate_Command_Or_Option; - - -------------------------- - -- Validate_Unix_Switch -- - -------------------------- - - procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is - begin - if S (S'First) = '`' then - return; - end if; - - pragma Assert (S (S'First) = '-' or else S (S'First) = '!'); - - for J in S'First + 1 .. S'Last loop - pragma Assert (S (J) /= ' '); - - if S (J) = '!' then - pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-'); - null; - end if; - end loop; - end Validate_Unix_Switch; - - -------------------- - -- VMS_Conversion -- - -------------------- - - procedure VMS_Conversion (The_Command : out Command_Type) is - Result : Command_Type := Undefined; - Result_Set : Boolean := False; - - begin - Buffer.Init; - - -- First we must preprocess the string form of the command and options - -- list into the internal form that we use. - - Preprocess_Command_Data; - - -- If no parameters, give complete list of commands - - if Argument_Count = 0 then - Output_Version; - New_Line; - Put_Line ("List of available commands"); - New_Line; - - while Commands /= null loop - - -- No usage for GNAT SYNC - - if Commands.Command /= Sync then - Put (Commands.Usage.all); - Set_Col (53); - Put_Line (Commands.Unix_String.all); - end if; - - Commands := Commands.Next; - end loop; - - raise Normal_Exit; - end if; - - -- Loop through arguments - - Arg_Num := 1; - while Arg_Num <= Argument_Count loop - Process_Argument (Result); - - if not Result_Set then - The_Command := Result; - Result_Set := True; - end if; - end loop; - - -- Gross error checking that the number of parameters is correct. - -- Not applicable to Unlimited_Files parameters. - - if (Param_Count = Command.Params'Length - 1 - and then Command.Params (Param_Count + 1) = Unlimited_Files) - or else Param_Count <= Command.Params'Length - then - null; - - else - Put_Line (Standard_Error, - "Parameter count of " - & Integer'Image (Param_Count) - & " not equal to expected " - & Integer'Image (Command.Params'Length)); - Put (Standard_Error, "usage: "); - Put_Line (Standard_Error, Command.Usage.all); - Errors := Errors + 1; - end if; - - if Errors > 0 then - raise Error_Exit; - else - -- Prepare arguments for a call to spawn, filtering out - -- embedded nulls place there to delineate strings. - - Process_Buffer (String (Buffer.Table (1 .. Buffer.Last))); - - if Cargs_Buffer.Last > 1 then - Last_Switches.Append (new String'("-cargs")); - Process_Buffer - (String (Cargs_Buffer.Table (1 .. Cargs_Buffer.Last))); - end if; - end if; - end VMS_Conversion; - -end VMS_Conv; diff --git a/main/gcc/ada/vms_conv.ads b/main/gcc/ada/vms_conv.ads deleted file mode 100644 index bba701505df..00000000000 --- a/main/gcc/ada/vms_conv.ads +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- V M S _ C O N V -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of the GNAT driver. It contains the procedure --- VMS_Conversion to convert a VMS command line to the equivalent command --- line with switches for the GNAT tools that the GNAT driver will invoke. --- The qualifier declarations are contained in package VMS_Data. - -with Table; -with VMS_Data; use VMS_Data; -with VMS_Cmds; use VMS_Cmds; - -with GNAT.OS_Lib; use GNAT.OS_Lib; - -package VMS_Conv is - - -- A table to keep the switches on the command line - - package Last_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.Last_Switches"); - - Normal_Exit : exception; - -- Raise this exception for normal program termination - - Error_Exit : exception; - -- Raise this exception if error detected - - Errors : Natural := 0; - -- Count errors detected - - Display_Command : Boolean := False; - -- Set true if /? switch causes display of generated command (on VMS) - - ------------------- - -- Command Table -- - ------------------- - - -- The command table contains an entry for each command recognized by - -- GNATCmd. The entries are represented by an array of records. - - type Parameter_Type is - -- A parameter is defined as a whitespace bounded string, not beginning - -- with a slash. (But see note under FILES_OR_WILDCARD). - (File, - -- A required file or directory parameter - - Optional_File, - -- An optional file or directory parameter - - Other_As_Is, - -- A parameter that's passed through as is (not canonicalized) - - Unlimited_Files, - -- An unlimited number of whitespace separate file or directory - -- parameters including wildcard specifications. - - Unlimited_As_Is, - -- An unlimited number of whitespace separated parameters that are - -- passed through as is (not canonicalized). - - Files_Or_Wildcard); - -- A comma separated list of files and/or wildcard file specifications. - -- A comma preceded by or followed by whitespace is considered as a - -- single comma character w/o whitespace. - - type Parameter_Array is array (Natural range <>) of Parameter_Type; - type Parameter_Ref is access all Parameter_Array; - - type Alternate_Command is (Comp, Ls, Kr, Pp, Prep); - -- Alternate command label for non VMS system use - - Corresponding_To : constant array (Alternate_Command) of Command_Type := - (Comp => Compile, - Ls => List, - Kr => Krunch, - Prep => Preprocess, - Pp => Pretty); - -- Mapping of alternate commands to commands - - type Command_Entry is record - Cname : String_Ptr; - -- Command name for GNAT xxx command - - Usage : String_Ptr; - -- A usage string, used for error messages - - Unixcmd : String_Ptr; - -- Corresponding Unix command - - Unixsws : Argument_List_Access; - -- Switches for the Unix command - - VMS_Only : Boolean; - -- When True, the command can only be used on VMS - - Switches : Switches_Ptr; - -- Pointer to array of switch strings - - Params : Parameter_Ref; - -- Describes the allowable types of parameters. - -- Params (1) is the type of the first parameter, etc. - -- An empty parameter array means this command takes no parameters. - - Defext : String (1 .. 3); - -- Default extension. If non-blank, then this extension is supplied by - -- default as the extension for any file parameter which does not have - -- an extension already. - end record; - - ------------------- - -- Switch Tables -- - ------------------- - - -- The switch tables contain an entry for each switch recognized by the - -- command processor. It is initialized by procedure Initialize. - - Command_List : array (Real_Command_Type) of Command_Entry; - - ---------------- - -- Procedures -- - ---------------- - - procedure Initialize; - -- Initialized the switch table Command_List - - procedure Output_Version; - -- Output the version of this program - - procedure VMS_Conversion (The_Command : out Command_Type); - -- Converts VMS command line to equivalent Unix command line - -end VMS_Conv; diff --git a/main/gcc/ada/vms_data.ads b/main/gcc/ada/vms_data.ads deleted file mode 100644 index d8118ba34af..00000000000 --- a/main/gcc/ada/vms_data.ads +++ /dev/null @@ -1,7772 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- V M S _ D A T A -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains, for each of the command of the GNAT driver, one --- constant array; each component of this array is a string that defines, --- in coded form as explained below, the conversion of a VMS qualifier of the --- command to the corresponding switch of the GNAT tool corresponding to the --- command. - --- This package is used by the GNAT driver to invokes the GNAT tools with the --- switches corresponding to the VMS qualifier and by the Project Manager to --- convert VMS qualifiers in project files to their corresponding switch --- values. - --- This package is also an input to the tool that generates the VMS GNAT --- help information automatically. - --- NOTE: the format of this package must follow the following rules, so that --- the VMS GNAT help tool works properly: - --- - Each command zone (where the eventual qualifiers are declared) must --- begin with a boxed comment of the form: - --- --------------------------------- --- -- Switches for GNAT -- --- --------------------------------- - --- where is the name of a GNAT command in capital letters, for --- example BIND, COMPILE, XREF, ... - --- - each qualifier declaration must be followed either by --- - a comment starting with "-- NODOC", to indicate that there is --- no documentation for this qualifier, or --- - a contiguous sequence of comments that constitute the --- documentation of the qualifier. - --- - each command zone ends with the declaration of the constant array --- for the command, of the form: - --- __Switches : aliased constant Switches := - -package VMS_Data is - - ---------------- - -- QUALIFIERS -- - ---------------- - - -- The syntax of a qualifier declaration is as follows: - - -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION" - - -- TRANSLATION ::= - -- DIRECT_TRANSLATION - -- | DIRECTORIES_TRANSLATION - -- | FILE_TRANSLATION - -- | NO_SPACE_FILE_TRANSL - -- | NUMERIC_TRANSLATION - -- | STRING_TRANSLATION - -- | OPTIONS_TRANSLATION - -- | COMMANDS_TRANSLATION - -- | ALPHANUMPLUS_TRANSLATION - -- | OTHER_TRANSLATION - - -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES - -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH * - -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH % - -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @ - -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH > - -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number # - -- STRING_TRANSLATION ::= =" UNIX_SWITCH " - -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION} - -- COMMANDS_TRANSLATION ::= =? ARGS space command-name - -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH | - - -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH} - - -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string' - - -- OPTION ::= option-name space UNIX_SWITCHES - - -- ARGS ::= -cargs | -bargs | -largs - - -- Here command-qual is the name of the switch recognized by the GNATCmd. - -- This is always given in upper case in the templates, although in the - -- actual commands, either upper or lower case is allowed. - - -- The unix-switch-string always starts with a minus, and has no commas - -- or spaces in it. Case is significant in the unix switch string. If a - -- unix switch string is preceded by the not sign (!) it means that the - -- effect of the corresponding command qualifier is to remove any previous - -- occurrence of the given switch in the command line. - - -- The DIRECTORIES_TRANSLATION format is used where a list of directories - -- is given. This possible corresponding formats recognized by GNATCmd are - -- as shown by the following example for the case of PATH - - -- PATH=direc - -- PATH=(direc,direc,direc,direc) - - -- When more than one directory is present for the DIRECTORIES case, then - -- multiple instances of the corresponding unix switch are generated, - -- with the file name being substituted for the occurrence of *. - - -- The FILE_TRANSLATION format is similar except that only a single - -- file is allowed, not a list of files, and only one unix switch is - -- generated as a result. - - -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that - -- no space is inserted between the switch and the file name. - - -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case - -- except that the parameter is a decimal integer in the range 0 to 999999. - - -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or - -- more options to appear (although only in some cases does the use of - -- multiple options make logical sense). For example, taking the - -- case of ERRORS for GCC, the following are all allowed: - - -- /ERRORS=BRIEF - -- /ERRORS=(FULL,VERBOSE) - -- /ERRORS=(BRIEF IMMEDIATE) - - -- If no option is provided (e.g. just /ERRORS is written), then the - -- first option in the list is the default option. For /ERRORS this - -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL. - - -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond - -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated - -- is one of these three possibilities). The name given by COMMAND is the - -- corresponding command name to be used to interpret the switches to be - -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS - -- sets the mode so that all subsequent switches, up to another switch - -- with COMMANDS_TRANSLATION apply to the corresponding commands issued - -- by the make utility. For example - - -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN - -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX - - -- Clearly these switches must come at the end of the list of switches - -- since all subsequent switches apply to an issued command. - - -- For the DIRECT_TRANSLATION case, an implicit additional qualifier - -- declaration is created by prepending NO to the name of the qualifier, - -- and then inverting the sense of the UNIX_SWITCHES string. For example, - -- given the qualifier definition: - - -- "/LIST -gnatl" - - -- An implicit qualifier definition is created: - - -- "/NOLIST !-gnatl" - - -- In the case where, a ! is already present, inverting the sense of the - -- switch means removing it. - - subtype S is String; - -- A synonym to shorten the table - - type String_Ptr is access constant String; - -- String pointer type used throughout - - type Switches is array (Natural range <>) of String_Ptr; - -- Type used for array of switches - - type Switches_Ptr is access constant Switches; - - ---------------------------- - -- Switches for GNAT BIND -- - ---------------------------- - - S_Bind_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Bind_ALI : aliased constant S := "/ALI_LIST " & - "-A"; - -- /NOALI_LIST (D) - -- /ALI_LIST - -- - -- Output full names of all the ALI files in the partition. The output is - -- written to SYS$OUTPUT. - - S_Bind_Bind : aliased constant S := "/BIND_FILE=" & - "ADA " & - "-A " & - "C " & - "-C"; - -- /BIND_FILE[=bind-file-option] - -- - -- Specifies the language of the binder generated file. - -- - -- ADA (D) Binder file is Ada. - -- - -- C Binder file is 'C'. - - S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" & - "-L|"; - -- /BUILD_LIBRARY=xxx - -- - -- Binds the units for library building. In this case the adainit and - -- adafinal procedures are rename to xxxinit and xxxfinal. Implies - -- /NOMAIN. - - S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- /NOCURRENT_DIRECTORY - -- - -- Look for source, library or object files in the default directory. - - S_Bind_Debug : aliased constant S := "/DEBUG=" & - "TRACEBACK " & - "-g2 " & - "ALL " & - "-g3 " & - "NONE " & - "-g0 " & - "SYMBOLS " & - "-g1 " & - "NOSYMBOLS " & - "!-g1 " & - "LINK " & - "-g3 " & - "NOTRACEBACK " & - "!-g2"; - -- /DEBUG[=debug-level] - -- /NODEBUG - -- - -- Specify level of debugging information generated for the elaboration - -- routine. See corresponding qualifier for GNAT COMPILE. - - S_Bind_DebugX : aliased constant S := "/NODEBUG " & - "!-g"; - -- NODOC (see /DEBUG) - - S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " & - "-e"; - -- /ELABORATION_DEPENDENCIES - -- /NOELABORATION_DEPENDENCIES (D) - -- - -- Output complete list of elaboration-order dependencies, showing the - -- reason for each dependency. This output can be rather extensive but may - -- be useful in diagnosing problems with elaboration order. The output is - -- written to SYS$OUTPUT. - - S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" & - "-m#"; - -- /ERROR_LIMIT=nnn - -- - -- Limit number of detected errors to nnn (1-999999). - - S_Bind_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Bind_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Bind_Force : aliased constant S := "/FORCE_ELAB_FLAGS " & - "-F"; - -- /NOFORCE_ELAB_FLAGS (D) - -- /FORCE_ELAB_FLAGS - -- - -- Force checking of elaboration Flags - - S_Bind_Help : aliased constant S := "/HELP " & - "-h"; - -- /HELP - -- - -- Output usage information. - - S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" & - "INVALID " & - "-Sin " & - "LOW " & - "-Slo " & - "HIGH " & - "-Shi"; - -- /INITIALIZE_SCALARS[=scalar-option] - -- - -- Indicate how uninitialized scalar values for which a pragma - -- Initialize_Scalars applies should be initialized. - -- scalar-option may be one of the following: - -- - -- INVALID (D) Initialize with an invalid value. - -- LOW Initialize with the lowest valid value of the subtype. - -- HIGH Initialize with the highest valid value of the subtype. - - S_Bind_Leap : aliased constant S := "/ENABLE_LEAP_SECONDS " & - "-y"; - -- /ENABLE_LEAP_SECONDS - -- /NOENABLE_LEAP_SECONDS (D) - -- - -- Enable leap seconds support in Ada.Calendar and its children. - - S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" & - "-aO*"; - -- /LIBRARY_SEARCH=(direc[,...]) - -- - -- When looking for library and object files look also in directories - -- specified. - - S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " & - "-K"; - -- /NOLINKER_OPTION_LIST (D) - -- /LINKER_OPTION_LIST - -- - -- Output linker options to SYS$OUTPUT. Includes library search - -- paths, contents of pragmas Ident and Linker_Options, and - -- libraries added by GNAT BIND. - - S_Bind_Main : aliased constant S := "/MAIN " & - "!-n"; - -- /MAIN (D) - -- - -- The main program is in Ada. - -- - -- /NOMAIN - -- - -- The main program is not in Ada. - - S_Bind_Alloc32 : aliased constant S := "/32_MALLOC " & - "-H32"; - -- /32_MALLOC - -- - -- Use 32-bit allocations for `__gnat_malloc' (and thus for - -- access types). - - S_Bind_Alloc64 : aliased constant S := "/64_MALLOC " & - "-H64"; - -- /64_MALLOC - -- - -- Use 64-bit allocations for `__gnat_malloc' (and thus for - -- access types). - - S_Bind_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; - -- /NOSTD_INCLUDES - -- - -- Do not look for sources the in the system default directory. - - S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & - "-nostdlib"; - -- /NOSTD_LIBRARIES - -- - -- Do not look for library files in the system default directory. - - S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " & - "-t"; - -- NODOC (see /TIME_STAMP_CHECK) - - S_Bind_Object : aliased constant S := "/OBJECT_LIST " & - "-O"; - -- /NOOBJECT_LIST (D) - -- /OBJECT_LIST - -- - -- Output full names of all the object files that must be linked to - -- provide the Ada component of the program. The output is written to - -- SYS$OUTPUT. - - S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " & - "-l"; - -- /NOORDER_OF_ELABORATION (D) - -- /ORDER_OF_ELABORATION - -- - -- Output chosen elaboration order. The output is written to SYS$OUTPUT. - - S_Bind_Output : aliased constant S := "/OUTPUT=@" & - "-o@"; - -- /OUTPUT=filename - -- - -- File name to use for the program containing the elaboration code. - - S_Bind_OutputX : aliased constant S := "/NOOUTPUT " & - "-c"; - -- /NOOUTPUT - -- - -- Check only. Do not generate the binder output file. - -- - -- In this mode the binder performs all error checks but does not generate - -- an output file. - - S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " & - "-p"; - -- /PESSIMISTIC_ELABORATION - -- - -- Causes the binder to choose a "pessimistic" elaboration order, i.e. one - -- which is most likely to cause elaboration order problems. This can be - -- useful in testing portable code to make sure that there are no missing - -- elaborate pragmas. - - S_Bind_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- binder. The source and object directories to be searched will be - -- communicated to the binder through logical names ADA_PRJ_INCLUDE_FILE - -- and ADA_PRJ_OBJECTS_FILE. - - S_Bind_Read : aliased constant S := "/READ_SOURCES=" & - "ALL " & - "-s " & - "NONE " & - "-x " & - "AVAILABLE " & - "!-x,!-s"; - -- /READ_SOURCES[=(keyword[,...])] - -- /NOREAD_SOURCES - -- - -- The following keyword are accepted: - -- - -- ALL (D) Require source files to be present. In this mode, the - -- binder insists on being able to locate all source files - -- that are referenced and checks their consistency. In - -- normal mode, if a source file cannot be located it is - -- simply ignored. If you specify the ALL keyword, a - -- missing source file is an error. - -- - -- NONE Exclude source files. In this mode, the binder only - -- checks that ALI files are consistent with one another. - -- source files are not accessed. The binder runs faster - -- in this mode, and there is still a guarantee that the - -- resulting program is self-consistent. - -- - -- If a source file has been edited since it was last - -- compiled and you specify the NONE keyword, the binder - -- will not detect that the object file is out of date - -- with the source file. - -- - -- This is the same as specifying /NOREAD_SOURCES. - -- - -- AVAILABLE Check that object files are consistent with one - -- another and are consistent with any source files that - -- can be located. - - S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " & - "-x"; - -- NODOC (see /READ_SOURCES) - - S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" & - "-M>"; - -- /RENAME_MAIN=xxx - -- - -- Renames the generated main program from main to xxx. - -- This is useful in the case of some cross-building environments, where - -- the actual main program is separate from the one generated - -- by GNAT BIND. - - S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" & - "VERBOSE " & - "-v " & - "BRIEF " & - "-b " & - "DEFAULT " & - "!-b,!-v"; - -- /REPORT_ERRORS[=(keyword[,...])] - -- VERBOSE (D) - -- BRIEF - -- DEFAULT - -- /NOREPORT_ERRORS - -- - -- With the DEFAULT keyword (which is not the default when the binder is - -- run from GNAT BIND) or the /NOREPORT_ERRORS qualifier, brief error - -- messages are generated to SYS$ERROR. If the VERBOSE keyword is - -- present, a header is written to SYS$OUTPUT and any error messages are - -- directed to SYS$OUTPUT All that is written to SYS$ERROR is a brief - -- summary message. - -- - -- If the BRIEF keyword is specified, the binder will generate brief error - -- messages to SYS$ERROR even if verbose mode is specified. This is - -- relevant only when used together with the VERBOSE keyword or /VERBOSE - -- qualifier. - - S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " & - "!-b,!-v"; - -- NODOC (see /REPORT_ERRORS) - - S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " & - "-r"; - -- /NORESTRICTION_LIST (D) - -- /RESTRICTION_LIST - -- - -- Generate list of pragma Restrictions that could be applied to the - -- current unit. This is useful for code audit purposes, and also may be - -- used to improve code generation in some cases. - - S_Bind_Return : aliased constant S := "/RETURN_CODES=" & - "POSIX " & - "!-X1 " & - "VMS " & - "-X1"; - -- /RETURN_CODES=POSIX (D) - -- /RETURN_CODES=VMS - -- - -- Specifies the style of default exit code returned. Must be used in - -- conjunction with and match the Link qualifier with same name. - -- - -- POSIX (D) Return Posix success (0) by default. - -- - -- VMS Return VMS success (1) by default. - - S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & - "--RTS=|"; - -- /RUNTIME_SYSTEM=xxx - -- - -- Binds against an alternate runtime system named xxx or RTS-xxx. - - S_Bind_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory[,...]) - -- - -- When looking for source or object files also look in directories - -- specified. - -- - -- This is the same as specifying both /LIBRARY_SEARCH and /SOURCE_SEARCH - -- for a directory. - - S_Bind_Shared : aliased constant S := "/SHARED " & - "-shared,!-static"; - -- /SHARED - -- /NOSHARED - -- - -- Link against a shared GNAT run time when available. - - S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" & - "-T#"; - -- /TIME_SLICE=nnn - -- - -- Set the time slice value to nnn milliseconds. A value of zero means no - -- time slicing and also indicates to the tasking run time to match as - -- close as possible to the annex D requirements of the RM. - - S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" & - "-aI*"; - -- /SOURCE_SEARCH=(directory[,...]) - -- - -- When looking for source files also look in directories specified. - - S_Bind_Static : aliased constant S := "/STATIC " & - "-static,!-shared"; - -- /STATIC - -- /NOSTATIC - -- - -- Link against a static GNAT run time. - - S_Bind_Store : aliased constant S := "/STORE_TRACEBACKS " & - "-E"; - -- /STORE_TRACEBACKS (D) - -- /NOSTORE_TRACEBACKS - -- - -- Store tracebacks in exception occurrences. - -- This is the default on VMS, with the zero-cost exception mechanism. - -- This qualifier has no impact, except when using the setjmp/longjmp - -- exception mechanism, with the GNAT COMPILE qualifier /LONGJMP_SETJMP. - - S_Bind_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " & - "!-t"; - -- /TIME_STAMP_CHECK (D) - -- - -- Time stamp errors will be treated as errors. - -- - -- /NOTIME_STAMP_CHECK - -- - -- Ignore time stamp errors. Any time stamp error messages are treated as - -- warning messages. This switch essentially disconnects the normal - -- consistency checking, and the resulting program may have undefined - -- semantics if inconsistent units are present. - -- - -- This means that /NOTIME_STAMP_CHECK should be used only in unusual - -- situations, with extreme care. - - S_Bind_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /VERBOSE (D) - -- /NOVERBOSE - -- - -- Equivalent to /REPORT_ERRORS=VERBOSE. - - S_Bind_Warn : aliased constant S := "/WARNINGS=" & - "NORMAL " & - "!-ws,!-we " & - "SUPPRESS " & - "-ws " & - "ERROR " & - "-we"; - -- /WARNINGS[=(keyword[,...])] - -- /NOWARNINGS - -- - -- The following keywords are supported: - -- - -- NORMAL (D) Print warning messages and treat them as warning. - -- SUPPRESS Suppress all warning messages (same as /NOWARNINGS). - -- ERROR Treat any warning messages as fatal errors - - S_Bind_WarnX : aliased constant S := "/NOWARNINGS " & - "-ws"; - -- NODOC (see /WARNINGS) - - S_Bind_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & - "BRACKETS " & - "-gnatWb " & - "HEX " & - "-gnatWh " & - "UPPER " & - "-gnatWu " & - "SHIFT_JIS " & - "-gnatWs " & - "UTF8 " & - "-gnatW8 " & - "EUC " & - "-gnatWe"; - -- /NOWIDE_CHARACTER_ENCODING (D) - -- /WIDE_CHARACTER_ENCODING[=encode-type] - -- - -- Specifies the mechanism used to encode wide characters, overriding - -- the default as set by the /WIDE_CHARACTER_ENCODING option for the - -- compilation of the main program. - - S_Bind_Zero : aliased constant S := "/ZERO_MAIN " & - "-z"; - -- /NOZERO_MAIN (D) - -- /ZERO_MAIN - -- - -- Normally the binder checks that the unit name given on the command line - -- corresponds to a suitable main subprogram. When /ZERO_MAIN is used, - -- a list of ALI files can be given, and the execution of the program - -- consists of elaboration of these units in an appropriate order. - - Bind_Switches : aliased constant Switches := - (S_Bind_Add 'Access, - S_Bind_ALI 'Access, - S_Bind_Bind 'Access, - S_Bind_Build 'Access, - S_Bind_Current 'Access, - S_Bind_Debug 'Access, - S_Bind_DebugX 'Access, - S_Bind_Elab 'Access, - S_Bind_Error 'Access, - S_Bind_Ext 'Access, - S_Bind_Follow 'Access, - S_Bind_Force 'Access, - S_Bind_Help 'Access, - S_Bind_Init 'Access, - S_Bind_Leap 'Access, - S_Bind_Library 'Access, - S_Bind_Linker 'Access, - S_Bind_Main 'Access, - S_Bind_Alloc32 'Access, - S_Bind_Alloc64 'Access, - S_Bind_Mess 'Access, - S_Bind_Nostinc 'Access, - S_Bind_Nostlib 'Access, - S_Bind_No_Time 'Access, - S_Bind_Object 'Access, - S_Bind_Order 'Access, - S_Bind_Output 'Access, - S_Bind_OutputX 'Access, - S_Bind_Pess 'Access, - S_Bind_Project 'Access, - S_Bind_Read 'Access, - S_Bind_ReadX 'Access, - S_Bind_Rename 'Access, - S_Bind_Report 'Access, - S_Bind_ReportX 'Access, - S_Bind_Restr 'Access, - S_Bind_Return 'Access, - S_Bind_RTS 'Access, - S_Bind_Search 'Access, - S_Bind_Shared 'Access, - S_Bind_Slice 'Access, - S_Bind_Source 'Access, - S_Bind_Static 'Access, - S_Bind_Store 'Access, - S_Bind_Subdirs 'Access, - S_Bind_Time 'Access, - S_Bind_Verbose 'Access, - S_Bind_Warn 'Access, - S_Bind_WarnX 'Access, - S_Bind_Wide 'Access, - S_Bind_Zero 'Access); - - ----------------------------- - -- Switches for GNAT CHECK -- - ----------------------------- - - S_Check_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Check_All : aliased constant S := "/ALL " & - "-a"; - -- /NOALL (D) - -- /ALL - -- - -- Also check the components of the GNAT run time and process the needed - -- components of the GNAT RTL when building and analyzing the global - -- structure for checking the global rules. - - S_Check_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Check_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Check_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Check_Help : aliased constant S := "/HELP " & - "-h"; - -- /NOHELP (D) - -- /HELP - -- - -- Print information about currently implemented checks. - - S_Check_Locs : aliased constant S := "/LOCS " & - "-l"; - -- /NOLOCS (D) - -- /LOCS - -- - -- Use full source locations references in the report file. - - S_Diagnosis : aliased constant S := "/DIAGNOSTIC_LIMIT=#" & - "-m#"; - -- /DIAGNOSTIC_LIMIT=500 (D) - -- /DIAGNOSTIC_LIMIT=nnn - -- - -- NNN is a decimal integer in the range of 1 to 1000 and limits the - -- number of diagnostic messages to be generated into Stdout to that - -- number. Once that number has been reached, gnatcheck stops - -- to print out diagnoses into Stderr. If NNN is equal to 0, this means - -- that there is no limit on the number of diagnoses in Stdout. - - S_Check_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Check_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- gnatcheck. The source directories to be searched will be communicated - -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. - - S_Check_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Work quietly, only output warnings and errors. - - S_Check_Time : aliased constant S := "/TIME " & - "-t"; - -- /NOTIME (D) - -- /TIME - -- - -- Print out execution time - - S_Check_Log : aliased constant S := "/LOG " & - "-log"; - -- /NOLOG (D) - -- /LOG - -- - -- Duplicate all the output sent to Stderr into a log file. - - S_Check_Short : aliased constant S := "/SHORT " & - "-s"; - -- /NOSHORT (D) - -- /SHORT - -- - -- Generate a short form of the report file. - - S_Check_Include : aliased constant S := "/INCLUDE_FILE=@" & - "--include-file=@"; - - -- /INCLUDE_FILE=filename - -- - -- Add the content of the specified text file to the generated report - -- file. - - S_Check_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Check_Template : aliased constant S := "/TEMPLATE=@" & - "--write-rules=@"; - -- /TEMPLATE=filename - -- - -- Generate the rule template into the specified file. - - S_Check_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- The version number and copyright notice are output, as well as exact - -- copies of the gnat1 commands spawned to obtain the chop control - -- information. - - S_Check_Out : aliased constant S := "/OUTPUT=@" & - "-o@"; - -- /OUTPUT=filename - -- - -- Specify the name of the output file. - - Check_Switches : aliased constant Switches := - (S_Check_Add 'Access, - S_Check_All 'Access, - S_Diagnosis 'Access, - S_Check_Ext 'Access, - S_Check_Files 'Access, - S_Check_Follow 'Access, - S_Check_Help 'Access, - S_Check_Locs 'Access, - S_Check_Mess 'Access, - S_Check_Project 'Access, - S_Check_Quiet 'Access, - S_Check_Time 'Access, - S_Check_Log 'Access, - S_Check_Short 'Access, - S_Check_Include 'Access, - S_Check_Subdirs 'Access, - S_Check_Template'Access, - S_Check_Verb 'Access, - S_Check_Out 'Access); - - ---------------------------- - -- Switches for GNAT CHOP -- - ---------------------------- - - S_Chop_Comp : aliased constant S := "/COMPILATION " & - "-c"; - -- /NOCOMPILATION (D) - -- /COMPILATION - -- - -- Compilation mode, handle configuration pragmas strictly according to - -- RM rules. - - S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" & - "-k#"; - -- /FILE_NAME_MAX_LENGTH[=nnn] - -- - -- Limit generated file names to NNN (default of 8) characters. This is - -- useful if the resulting set of files is required to be interoperable - -- with systems like MS-DOS which limit the length of file names. - - S_Chop_Help : aliased constant S := "/HELP " & - "-h"; - -- /NOHELP (D) - -- /HELP - -- - -- Print usage information. - - S_Chop_Over : aliased constant S := "/OVERWRITE " & - "-w"; - -- /NOOVERWRITE (D) - -- /OVERWRITE - -- - -- Overwrite existing file names. Normally GNAT CHOP regards it as a - -- fatal error situation if there is already a file with the same name as - -- a file it would otherwise output. The /OVERWRITE qualifier bypasses - -- this check, and any such existing files will be silently overwritten. - - S_Chop_Pres : aliased constant S := "/PRESERVE " & - "-p"; - -- /NOPRESERVE (D) - -- /PRESERVE - -- - -- Causes the file modification time stamp of the input file to be - -- preserved and used for the time stamp of the output file(s). This may - -- be useful for preserving coherency of time stamps in an environment - -- where gnatchop is used as part of a standard build process. - - S_Chop_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Work quietly, only output warnings and errors. - - S_Chop_Ref : aliased constant S := "/REFERENCE " & - "-r"; - -- /NOREFERENCE (D) - -- /REFERENCE - -- - -- Generate "Source_Reference" pragmas. Use this qualifier if the output - -- files are regarded as temporary and development is to be done in terms - -- of the original unchopped file. The /REFERENCE qualifier causes - -- "Source_Reference" pragmas to be inserted into each of the generated - -- files to refers back to the original file name and line number. The - -- result is that all error messages refer back to the original unchopped - -- file. - -- - -- In addition, the debugging information placed into the object file - -- (when the /DEBUG qualifier of GNAT COMPILE or GNAT MAKE is specified) - -- also refers back to this original file so that tools like profilers - -- and debuggers will give information in terms of the original unchopped - -- file. - - S_Chop_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- The version number and copyright notice are output, as well as exact - -- copies of the gnat1 commands spawned to obtain the chop control - -- information. - - Chop_Switches : aliased constant Switches := - (S_Chop_Comp 'Access, - S_Chop_File 'Access, - S_Chop_Help 'Access, - S_Chop_Over 'Access, - S_Chop_Pres 'Access, - S_Chop_Quiet 'Access, - S_Chop_Ref 'Access, - S_Chop_Verb 'Access); - - ----------------------------- - -- Switches for GNAT CLEAN -- - ----------------------------- - - S_Clean_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Clean_Compil : aliased constant S := "/COMPILER_FILES_ONLY " & - "-c"; - -- /NOCOMPILER_FILES_ONLY (D) - -- /COMPILER_FILES_ONLY - -- - -- Only attempt to delete the files produced by the compiler, not those - -- produced by the binder or the linker. The files that are not to be - -- deleted are library files, interface copy files, binder generated files - -- and executable files. - - S_Clean_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- - -- Look for ALI or object files in the directory where GNAT CLEAN was - -- invoked. - -- - -- /NOCURRENT_DIRECTORY - -- - -- Do not look for ALI or object files in the directory where GNAT CLEAN - -- was invoked. - - S_Clean_Delete : aliased constant S := "/DELETE " & - "!-n"; - -- /DELETE (D) - -- - -- Delete the files that are not read-only. - -- - -- /NODELETE - -- - -- Informative-only mode. Do not delete any files. Output the list of the - -- files that would have been deleted if this switch was not specified. - - S_Clean_Dirobj : aliased constant S := "/DIRECTORY_OBJECTS=@" & - "-D@"; - -- /DIRECTORY_OBJECTS= - -- - -- Find the object files and .ALI files in . - -- This qualifier is not compatible with /PROJECT_FILE. - - S_Clean_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Clean_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Clean_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & - "-F"; - -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) - -- /FULL_PATH_IN_BRIEF_MESSAGES - -- - -- When using project files, if some errors or warnings are detected - -- during parsing and verbose mode is not in effect (no use of qualifier - -- /VERBOSE), then error lines start with the full path name of the - -- project file, rather than its simple file name. - - S_Clean_Help : aliased constant S := "/HELP " & - "-h"; - -- /NOHELP (D) - -- /HELP - -- - -- Output a message explaining the usage of gnatclean. - - S_Clean_Index : aliased constant S := "/SOURCE_INDEX=#" & - "-i#"; - -- /SOURCE_INDEX=nnn - -- - -- Specifies the index of the units in the source file - -- By default, source files are mono-unit and there is no index - - S_Clean_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Clean_Object : aliased constant S := "/OBJECT_SEARCH=*" & - "-aO*"; - -- /OBJECT_SEARCH=(directory,...) - -- - -- When searching for library and object files, look in the specified - -- directories. The order in which library files are searched is the same - -- as for MAKE. - - S_Clean_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- compiler. The source and object directories to be searched will be - -- communicated to gnatclean through logical names ADA_PRJ_INCLUDE_FILE - -- and ADA_PRJ_OBJECTS_FILE. - - S_Clean_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Quiet output. If there are no error, do not output anything, except in - -- verbose mode (qualifier /VERBOSE) or in informative-only mode - -- (qualifier /NODELETE). - - S_Clean_Recurs : aliased constant S := "/RECURSIVE " & - "-r"; - -- /NORECURSIVE (D) - -- /RECURSIVE - -- - -- When a project file is specified (using switch -P), clean all imported - -- and extended project files, recursively. If this qualifier is not - -- specified, only the files related to the main project file are to be - -- deleted. This qualifier has no effect if no project file is specified. - - S_Clean_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory,...) - -- - -- Equivalent to /OBJECT_SEARCH=(directory,...). - - S_Clean_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Clean_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & - "--unchecked-shared-lib-imports"; - -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) - -- /UNCHECKED_SHARED_LIB_IMPORTS - -- - -- Allow shared library projects to import static library projects - - S_Clean_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Verbose mode. - - Clean_Switches : aliased constant Switches := - (S_Clean_Add 'Access, - S_Clean_Compil 'Access, - S_Clean_Current'Access, - S_Clean_Delete 'Access, - S_Clean_Dirobj 'Access, - S_Clean_Ext 'Access, - S_Clean_Follow 'Access, - S_Clean_Full 'Access, - S_Clean_Help 'Access, - S_Clean_Index 'Access, - S_Clean_Mess 'Access, - S_Clean_Object 'Access, - S_Clean_Project'Access, - S_Clean_Quiet 'Access, - S_Clean_Recurs 'Access, - S_Clean_Search 'Access, - S_Clean_Subdirs'Access, - S_Clean_Verbose'Access, - S_Clean_USL 'Access); - - ------------------------------- - -- Switches for GNAT COMPILE -- - ------------------------------- - - S_GCC_Ada_83 : aliased constant S := "/83 " & - "-gnat83"; - -- /NO83 (D) - -- /83 - -- - -- Although GNAT is primarily an Ada 95 compiler, it accepts this - -- qualifier to specify that an Ada 83 mode program is being compiled. If - -- you specify this qualifier, GNAT rejects Ada 95 extensions and applies - -- Ada 83 semantics. It is not possible to guarantee this qualifier does - -- a perfect job; for example, some subtle tests of pathological cases, - -- such as are found in ACVC tests that have been removed from the ACVC - -- suite for Ada 95, may not compile correctly. However for practical - -- purposes, using this qualifier should ensure that programs that - -- compile correctly under the /83 qualifier can be ported reasonably - -- easily to an Ada 83 compiler. This is the main use of this qualifier. - -- - -- With few exceptions (most notably the need to use "<>" on - -- unconstrained generic formal parameters), it is not necessary to use - -- this qualifier switch when compiling Ada 83 programs, because, with - -- rare and obscure exceptions, Ada 95 is upwardly compatible with Ada - -- 83. This means that a correct Ada 83 program is usually also a correct - -- Ada 95 program. - - S_GCC_Ada_95 : aliased constant S := "/95 " & - "-gnat95"; - -- /95 (D) - -- - -- Allows GNAT to recognize the full range of Ada 95 constructs. - -- This is the normal default for GNAT Pro. - - S_GCC_Ada_05 : aliased constant S := "/05 " & - "-gnat05"; - -- /05 (D) - -- - -- Allows GNAT to recognize the full range of Ada 2005 constructs. - - S_GCC_Ada_2005 : aliased constant S := "/2005 " & - "-gnat2005"; - -- /05 (D) - -- - -- Allows GNAT to recognize the full range of Ada 2005 constructs. - -- Equivalent to /05 (/2005 is the preferred usage). - - S_GCC_Ada_12 : aliased constant S := "/12 " & - "-gnat12"; - -- /05 (D) - -- - -- Allows GNAT to recognize all implemented proposed Ada 2012 - -- extensions. See features file for list of implemented features. - - S_GCC_Ada_2012 : aliased constant S := "/2012 " & - "-gnat2012"; - -- /05 (D) - -- - -- Allows GNAT to recognize all implemented proposed Ada 2012 - -- extensions. See features file for list of implemented features. - -- Equivalent to /12 (/2012 is the preferred usage). - - S_GCC_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_GCC_AlCheck : aliased constant S := "/ALIASING_CHECK " & - "-gnateA"; - -- /NOALIASING_CHECK (D) - -- /ALIASING_CHECK - -- - -- Check that there are no aliased parameters in subprogram calls. - - S_GCC_Asm : aliased constant S := "/ASM " & - "-S,!-c"; - -- /NOASM (D) - -- /ASM - -- - -- Use to cause the assembler source file to be generated, using S as the - -- filetype, instead of the object file. This may be useful if you need - -- to examine the generated assembly code. - - S_GCC_AValid : aliased constant S := "/ASSUME_VALID " & - "-gnatB"; - -- /NO_ASSUME_VALID (D) - -- /ASSUME_VALID - -- - -- Use to tell the compiler to assume that all objects have valid values - -- except those occurring as prefixes to 'Valid attributes. In the default - -- mode, the compiler assumes that values may be invalid unless it can - -- be sure that they are valid, and code is generated to allow for this - -- possibility. The use of /ASSUME_VALID will improve the code. - - S_GCC_CategW : aliased constant S := "/CATEGORIZATION_WARNINGS " & - "-gnateP"; - -- /NO_CATEGORIZATION_WARNINGS (D) - -- /CATEGORIZATION_WARNINGS - -- - -- Use to tell the compiler to disable categorization dependency errors. - -- Ada requires that units that WITH one another have compatible - -- categories, for example a Pure unit cannot WITH a Preelaborate unit. - -- If this switch is used, these errors become warnings (which can be - -- ignored, or suppressed in the usual manner). This can be useful in - -- some specialized circumstances such as the temporary use of special - -- test software. - - S_GCC_Checks : aliased constant S := "/CHECKS=" & - "FULL " & - "-gnato,!-gnatE,!-gnatp " & - "OVERFLOW " & - "-gnato " & - "ELABORATION " & - "-gnatE " & - "ASSERTIONS " & - "-gnata " & - "DEFAULT " & - "!-gnato,!-gnatp " & - "STACK " & - "-fstack-check " & - "SUPPRESS_ALL " & - "-gnatp " & - "UNSUPPRESS_ALL " & - "-gnat-p"; - -- /NOCHECKS - -- /CHECKS[=(keyword[,...])] - -- - -- If you compile with the default options, GNAT will insert many runtime - -- checks into the compiled code, including code that performs range - -- checking against constraints, but not arithmetic overflow checking for - -- integer operations (including division by zero) or checks for access - -- before elaboration on subprogram calls. All other runtime checks, as - -- required by the Ada 95 Reference Manual, are generated by default. - -- - -- You may specify one or more of the following keywords to the /CHECKS - -- qualifier to modify this behavior: - -- - -- DEFAULT The behavior described above. This is the default - -- if the /CHECKS qualifier is not present on the - -- command line. Same as /NOCHECKS. - -- - -- OVERFLOW Enables overflow checking in CHECKED mode for integer - -- operations and checks for access before elaboration - -- on subprogram calls. This causes GNAT to generate - -- slower and larger executable programs by adding code - -- to check for both overflow and division by zero - -- (resulting in raising "Constraint_Error" as required - -- by Ada semantics). - -- Similarly, GNAT does not generate elaboration check - -- by default, and you must specify this keyword to - -- enable them. - -- - -- Note that this keyword does not affect the code - -- generated for any floating-point operations; it - -- applies only to integer operations. For the case of - -- floating-point, GNAT has the "Machine_Overflows" - -- attribute set to "False" and the normal mode of - -- operation is to generate IEEE NaN and infinite values - -- on overflow or invalid operations (such as dividing - -- 0.0 by 0.0). - -- - -- ELABORATION Enables dynamic checks for access-before-elaboration - -- on subprogram calls and generic instantiations. - -- - -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no - -- effect and are ignored. This keyword causes "Assert" - -- and "Debug" pragmas to be activated, as well as - -- "Check", "Precondition" and "Postcondition" pragmas. - -- - -- SUPPRESS_ALL Suppress all runtime checks as though you have - -- "pragma Suppress (all_checks)" in your source. Use - -- this switch to improve the performance of the code at - -- the expense of safety in the presence of invalid data - -- or program bugs. - -- - -- UNSUPPRESS_ALL Cancels effect of previous SUPPRESS_ALL. - -- - -- DEFAULT Suppress the effect of any option OVERFLOW or - -- ASSERTIONS. - -- - -- FULL (D) Similar to OVERFLOW, but suppress the effect of any - -- option ELABORATION or SUPPRESS_ALL. - -- - -- These keywords only control the default setting of the checks. You - -- may modify them using either "Suppress" (to remove checks) or - -- "Unsuppress" (to add back suppressed checks) pragmas in your program - -- source. - - S_GCC_ChecksX : aliased constant S := "/NOCHECKS " & - "-gnatp,!-gnato,!-gnatE"; - -- NODOC (see /CHECKS) - - S_GCC_Chflov : aliased constant S := "/FLOAT_OVERFLOW_CHECK " & - "-gnateF"; - -- /NOFLOAT_OVERFLOW_CHECK (D) - -- /FLOAT_OVERFLOW_CHECK - -- - -- Set mode to check overflow for all floating-point operations including - -- those using an unconstrained predefined type (i.e. no infinities). - - S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " & - "-gnatC"; - -- /NOCOMPRESS_NAMES (D) - -- /COMPRESS_NAMES - -- - -- Compress debug information and external symbol name table entries. - -- In the generated debugging information, and also in the case of long - -- external names, the compiler uses a compression mechanism if the name - -- is very long. This compression method uses a checksum, and avoids - -- trouble on some operating systems which have difficulty with very long - -- names. - - S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & - "-gnatec>"; - -- /CONFIGURATION_PRAGMAS_FILE=file - -- - -- Specify a configuration pragmas file that needs to be taken into - -- account. - - S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- /NOCURRENT_DIRECTORY - -- - -- Look for source files in the default directory. - - S_GCC_Data : aliased constant S := "/DATA_PREPROCESSING=<" & - "-gnatep>"; - -- /DATA_PREPROCESSING=file_name - -- - -- This qualifier 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. - -- - -- A preprocessing data file is a text file with significant lines - -- indicating how should be preprocessed either a specific source or all - -- sources not mentioned in other lines. A significant line is a non - -- empty, non comment line. Comments are similar to Ada comments. - -- - -- Each significant line starts with either a literal string or the - -- character '*'. A literal string is the file name (without directory - -- information) of the source to preprocess. A character '*' indicates the - -- preprocessing for all the sources that are not specified explicitly on - -- other lines. It is an error to have two lines with the same file name - -- or two 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. (see 15.3 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 directory as a source directory through - -- qualifier "/SEARCH=[]", otherwise the compiler would not find the - -- definition file. - -- - -- Then, optionally, switches similar to those of gnatprep may be found. - -- Those switches are: - -- - -- -b Causes both preprocessor lines and the lines deleted by - -- preprocessing to be replaced by blank lines, preserving - -- the line number. This switch is always implied; - -- however, if specified after `-c' it cancels the effect - -- of `-c'. - -- - -- -c Causes both preprocessor lines and the lines deleted by - -- preprocessing to be retained as comments marked with - -- the special string "--! ". - -- - -- -Dsymbol=value Define or redefine a symbol, associated with value. - -- A symbol is an Ada identifier, or an Ada reserved word, - -- with the exception of "if", "else", "elsif", "end", - -- "and", "or" and "then". value is either a literal - -- string, an Ada identifier or any Ada reserved word. - -- A symbol declared with this switch replaces a symbol - -- with the same name defined in a definition file. - -- - -- -s Causes a sorted list of symbol names and values to be - -- listed on the standard output file. - -- - -- -u Causes undefined symbols to be treated as having the - -- value FALSE in the context 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. - -- - -- Examples of valid lines in a preprocessor data file: - -- - -- "toto.adb" "prep.def" -u - -- -- preprocess "toto.adb", using definition file "prep.def", - -- -- undefined symbol are False. - -- - -- * -c -DVERSION=V101 - -- -- preprocess all other sources without a definition file; - -- -- suppressed lined are commented; symbol VERSION has the value - -- -- V101. - -- - -- "titi.adb" "prep2.def" -s - -- -- preprocess "titi.adb", using definition file "prep2.def"; - -- -- list all symbols with their values. - - S_GCC_Debug : aliased constant S := "/DEBUG=" & - "SYMBOLS " & - "-g2 " & - "NOSYMBOLS " & - "!-g2 " & - "TRACEBACK " & - "-g1 " & - "ALL " & - "-g3 " & - "NONE " & - "-g0 " & - "NOTRACEBACK " & - "-g0"; - -- /DEBUG[=debug-level] - -- /NODEBUG - -- - -- Specifies how much debugging information is to be included in - -- the resulting object fie. - -- - -- 'debug-level' is one of the following: - -- - -- SYMBOLS (D) Include both debugger symbol records and traceback - -- in the object file. - -- - -- ALL Include debugger symbol records, traceback plus - -- extra debug information in the object file. - -- - -- NONE Excludes both debugger symbol records and traceback - -- from the object file. Same as /NODEBUG. - -- - -- TRACEBACK Includes only traceback records in the object - -- file. This is the default when /DEBUG is not used. - - S_GCC_DebugX : aliased constant S := "/NODEBUG " & - "!-g"; - -- NODOC (see /Debug) - - S_GCC_DisAtom : aliased constant S := "/DISABLE_ATOMIC_SYNCHRONIZATION " & - "-gnated"; - -- /NODISABLE_ATOMIC_SYNCHRONIZATION (D) - -- /DISABLE_ATOMIC_SYNCHRONIZATION - -- Disable synchronization of atomic variables. - - S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" & - "RECEIVER " & - "-gnatzr " & - "CALLER " & - "-gnatzc"; - -- /NODISTRIBUTION_STUBS (D) - -- /DISTRIBUTION_STUBS[=dist-opt] - -- - -- 'dist-opt' is either RECEIVER (the default) or SENDER and indicates - -- that stubs for use in distributed programs (see the Distributed - -- Systems Annex of the Ada RM) should be generated. - - S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " & - "!-gnatzr,!-gnatzc"; - -- NODISTRIBUTION_STUBS (see /DISTRIBUTION_STUBS) - - S_GCC_ElabI : aliased constant S := "/ELABORATION_INFO_MESSAGES " & - "-gnatel"; - -- ELABORATION_INFO_MESSAGES - -- - -- Causes the compiler to output INFO messages that show where implicit - -- Elaborate and Elaborate_All pragmas are added when using the static - -- elaboration model. Used to diagnose binder circularities when this - -- elaboration model is used. - - S_GCC_NoElabI : aliased constant S := "/NOELABORATION_INFO_MESSAGES " & - "-gnateL"; - -- Turns off elaboration info messages (see ELABORATION_INFO_MESSAGES) - - S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" & - "-gnatm#"; - -- /NOERROR_LIMIT (D) - -- /ERROR_LIMIT=nnn - -- - -- NNN is a decimal integer in the range of 1 to 999999 and limits the - -- number of error messages to be generated to that number. Once that - -- number has been reached, the compilation is abandoned. - -- Specifying 999999 is equivalent to /NOERROR_LIMIT. - - S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " & - "-gnatm999999"; - -- NODOC (see /ERROR_LIMIT) - - S_GCC_Except : aliased constant S := "/EXTRA_EXCEPTION_INFORMATION " & - "-gnateE"; - -- /EXTRA_EXCEPTION_INFORMATION - -- - -- Generate extra information in exception messages, in particular - -- display extra column information and the value and range associated - -- with index and range check failures, and extra column information for - -- access checks. - - S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " & - "-gnatG"; - -- /NOEXPAND_SOURCE (D) - -- /EXPAND_SOURCE - -- - -- Produces a listing of the expanded code in Ada source form. For - -- example, all tasking constructs are reduced to appropriate run-time - -- library calls. The maximum line length for the listing 72. - - S_GCC_Lexpand : aliased constant S := "/LEXPAND_SOURCE=#" & - "-gnatG#"; - -- /LEXPAND_SOURCE=nnn - -- - -- Produces a listing of the expanded code in Ada source form. For - -- example, all tasking constructs are reduced to appropriate run-time - -- library calls. The parameter is the maximum line length for the - -- listing. - - S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " & - "-gnatX"; - -- /NOEXTENSIONS_ALLOWED (D) - -- /EXTENSIONS_ALLOWED - -- - -- GNAT specific language extensions allowed. - - S_GCC_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" & - "-gnatk#"; - -- /FILE_NAME_MAX_LENGTH=nnn - -- - -- Activates file name "krunching". NNN, a decimal integer in the range - -- 1-999, indicates the maximum allowable length of a file name (not - -- including the ADS or ADB filetype. The default is not to enable file - -- name krunching. - - S_GCC_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_GCC_Force : aliased constant S := "/FORCE_ALI " & - "-gnatQ"; - -- /NOFORCE_ALI (D) - -- /FORCE_ALI - -- - -- In normal operation mode, the .ALI file is not generated if any - -- illegalities are detected in the program. The use of this qualifier - -- forces generation of the .ALI file. This file is marked as being - -- in error, so it cannot be used for binding purposes, but it does - -- contain reasonably complete cross-reference information, and thus may - -- be useful for use by tools (e.g. semantic browsing tools or integrated - -- development environments) that are driven from the .ALI file. - - S_GCC_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & - "-gnatef"; - -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) - -- /FULL_PATH_IN_BRIEF_MESSAGES - -- - -- When using project files, if some errors or warnings are detected - -- during parsing and verbose mode is not in effect (no use of qualifier - -- /VERBOSE), then error lines start with the full path name of the - -- project file, rather than its simple file name. - - S_GCC_Generate : aliased constant S := "/GENERATE_PROCESSED_SOURCE " & - "-gnateG"; - -- /NOGENERATE_PROCESSED_SOURCE (D) - -- /GENERATE_PROCESSED_SOURCE - -- - -- Generate a file _prep if the integrated preprocessing - -- is modifying the source text. - - S_GCC_GNAT : aliased constant S := "/GNAT_INTERNAL " & - "-gnatg"; - -- /NOGNAT_INTERNAL (D) - -- /GNAT_INTERNAL - -- - -- Internal GNAT implementation mode. This should not be used for - -- applications programs, it is intended only for use by the compiler - -- and its run-time library. For documentation, see the GNAT sources. - -- Note that it implies /WARNINGS=ALL,ERRORS and /STYLE_CHECKS=GNAT - -- so that all standard warnings and all standard style options are - -- turned on. All warnings and style error messages are treated as - -- errors. - - S_GCC_Help : aliased constant S := "/HELP " & - "-gnath"; - -- /NOHELP (D) - -- /HELP - -- - -- Output usage information. - - S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" & - "DEFAULT " & - "-gnati1 " & - "1 " & - "-gnati1 " & - "2 " & - "-gnati2 " & - "3 " & - "-gnati3 " & - "4 " & - "-gnati4 " & - "5 " & - "-gnati5 " & - "PC " & - "-gnatip " & - "PC850 " & - "-gnati8 " & - "FULL_UPPER " & - "-gnatif " & - "NO_UPPER " & - "-gnatin " & - "WIDE " & - "-gnatiw"; - -- /NOIDENTIFIER_CHARACTER_SET (D) - -- /IDENTIFIER_CHARACTER_SET=char-set - -- - -- Normally GNAT recognizes the Latin-1 character set in source program - -- identifiers, as described in the reference manual. This qualifier - -- causes GNAT to recognize alternate character sets in identifiers. - -- 'char-set' is one of the following strings indicating the character - -- set: - -- - -- DEFAULT (D) Equivalent to 1, below. Also equivalent to - -- /NOIDENTIFIER_CHARACTER_SET. - -- - -- 1 The basic character set is Latin-1. This character - -- set is defined by ISO standard 8859, part 1. The lower - -- half (character codes 16#00# ... 16#7F#) is identical - -- to standard ASCII coding, but the upper half is used - -- to represent additional characters. This includes - -- extended letters used by European languages, such as - -- the umlaut used in German. - -- - -- You may use any of these extended characters freely - -- in character or string literals. In addition, the - -- extended characters that represent letters can be - -- used in identifiers. - -- - -- 2 Latin-2 letters allowed in identifiers, with uppercase - -- and lowercase equivalence. - -- - -- 3 Latin-3 letters allowed in identifiers, with uppercase - -- and lower case equivalence. - -- - -- 4 Latin-4 letters allowed in identifiers, with uppercase - -- and lower case equivalence. - -- - -- PC IBM PC code page 437. This code page is the normal - -- default for PCs in the U.S. It corresponds to the - -- original IBM PC character set. This set has some, but - -- not all, of the extended Latin-1 letters, but these - -- letters do not have the same encoding as Latin-1. In - -- this mode, these letters are allowed in identifiers - -- with uppercase and lowercase equivalence. - -- - -- PC850 This code page (850) is a modification of 437 extended - -- to include all the Latin-1 letters, but still not with - -- the usual Latin-1 encoding. In this mode, all these - -- letters are allowed in identifiers with uppercase and - -- lower case equivalence. - -- - -- FULL_UPPER Any character in the range 80-FF allowed in - -- identifiers, and all are considered distinct. In - -- other words, there are no uppercase and lower case - -- equivalences in this range. - -- - -- NO_UPPER No upper-half characters in the range 80-FF are - -- allowed in identifiers. This gives Ada 95 - -- compatibility for identifier names. - -- - -- WIDE GNAT allows wide character codes to appear in - -- character and string literals, and also optionally - -- in identifiers. See the /WIDE_CHARACTER_ENCODING - -- qualifier for information on encoding formats. - - S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " & - "-gnati1"; - -- NODOC (see /IDENTIFIER_CHARACTER_SET) - - S_GCC_IgnoreR : aliased constant S := "/IGNORE_REP_CLAUSES " & - "-gnatI"; - -- /IGNORE_REP_CLAUSES - -- - -- Causes all representation clauses to be ignored and treated as - -- comments. Useful when compiling foreign code (for example when ASIS - -- is used to analyze such code). - - S_GCC_IgnoreS : aliased constant S := "/IGNORE_STYLE_CHECKS_PRAGMAS " & - "-gnateY"; - -- /IGNORE_STYLE_CHECKS_PRAGMAS - -- - -- Causes all Style_Checks pragmas to be checked for legality, but - -- otherwise ignored. Allows style checks to be fully controlled by - -- command line qualifiers. - - S_GCC_IgnoreU : aliased constant S := "/IGNORE_UNRECOGNIZED " & - "-gnateu"; - -- /IGNORE_UNRECOGNIZED - -- - -- Causes unrecognized style switches, validity switches, and warning - -- switches to be ignored rather than generating an error message. - - S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " & - "-gnatdO"; - -- /NOIMMEDIATE_ERRORS (D) - -- /IMMEDIATE_ERRORS - -- - -- Causes errors to be displayed as soon as they are encountered, rather - -- than after compilation is terminated. If GNAT terminates prematurely - -- or goes into an infinite loop, the last error message displayed may - -- help to pinpoint the culprit. - -- - -- Note that this qualifier is intended only for helping to diagnose - -- illegal programs when the compiler fails. It disconnects many of the - -- normal handling procedures for error messages, and may for example - -- cause malfunction of pragma Warnings. - - S_GCC_Inline : aliased constant S := "/INLINE=" & - "PRAGMA " & - "-gnatn " & - "PRAGMA_LEVEL_1 " & - "-gnatn1 " & - "PRAGMA_LEVEL_2 " & - "-gnatn2 " & - "FULL " & - "-gnatN " & - "SUPPRESS " & - "-fno-inline"; - -- /NOINLINE (D) - -- /INLINE[=keyword] - -- - -- Selects the level of inlining for your program. In the absence of this - -- qualifier, GNAT does not attempt inlining across units and does not - -- need to access the bodies of subprograms for which "pragma Inline" is - -- specified if they are not in the current unit. - -- - -- The supported keywords are as follows: - -- - -- PRAGMA (D) Recognize and process "Inline" pragmas. However, - -- for the inlining to actually occur, optimization - -- must be enabled. This enables inlining across unit - -- boundaries, that is, inlining a call in one unit of - -- a subprogram declared in a with'ed unit. The compiler - -- will access these bodies, creating an extra source - -- dependency for the resulting object file, and where - -- possible, the call will be inlined. - -- - -- This qualifier also turns on full optimization and - -- requests GNAT to try to attempt automatic inlining - -- of small subprograms within a unit. - -- - -- Specifying /OPTIMIZE=NONE will disable the main effect - -- of this qualifier, but you may specify other - -- optimization options, to get either lower - -- (/OPTIMIZE=SOME) or higher (/OPTIMIZE=UNROLL_LOOPS) - -- levels of optimization. - -- - -- PRAGMA_LEVEL_1 - -- Direct control of the level of "Inline" pragmas - -- optimization with moderate inlining across modules. - -- - -- PRAGMA_LEVEL_2 - -- Direct control of the level of "Inline" pragmas - -- optimization with full inlining across modules. - -- - -- FULL Front end inlining. The front end inlining activated - -- by this switch is generally more extensive, and quite - -- often more effective than the standard PRAGMA inlining - -- mode. It will also generate additional dependencies. - -- - -- SUPPRESS Suppresses all inlining, even if other optimization - -- or inlining switches are set. - - S_GCC_InlineX : aliased constant S := "/NOINLINE " & - "!-gnatn,!-gnatN"; - -- NODOC (see /INLINE) - - S_GCC_Intsrc : aliased constant S := "/INTERSPERSE_SOURCE " & - "-gnatL"; - - -- /NO_INTERSPERSE_SOURCE (D) - -- /INTERSPERSE_SOURCE - -- - -- Causes output from /XDEBUG or /EXPAND_SOURCE to be interspersed with - -- lines from the original source file, output as comment lines with the - -- associated line number. - - S_GCC_Just : aliased constant S := "/JUSTIFY_MESSAGES=#" & - "-gnatj#"; - - -- /NO_JUSTIFY_MESSAGES (D) - -- /JUSTIFY_MESSAGES=nnn - -- - -- Causes error messages to be reformatted so that a message and all its - -- continuation lines count as one warning or error in the statistics on - -- total errors, and the message is broken down into lines (justified) so - -- that no line is longer than nnn characters. The default message - -- behavior (each message counted separately and not reformatted to fit - -- a particular line length) can be obtained using /NO_JUSTIFY_MESSAGES. - - S_GCC_JustX : aliased constant S := "/NO_JUSTIFY_MESSAGES " & - "-gnatj0"; - - -- NODOC (see /JUSTIFY_MESSAGES) - - S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" & - "-gnatyM#"; - -- /MAX_LINE_LENGTH=nnn - -- - -- Set maximum line length. - -- The length of lines must not exceed the given value nnn. - - S_GCC_List : aliased constant S := "/LIST " & - "-gnatl"; - -- /NOLIST (D) - -- /LIST - -- - -- Cause a full listing of the file to be generated. In the case where - -- a body is compiled, the corresponding spec is also listed, along - -- with any subunits. - - S_GCC_Machine : aliased constant S := "/MACHINE_CODE_LISTING " & - "-source-listing"; - -- /NOMACHINE_CODE_LISTING (D) - -- /MACHINE_CODE_LISTING - -- - -- Cause a full machine code listing of the file to be generated to - -- .lis. Interspersed source is included if the /DEBUG - -- qualifier is also present. - - S_GCC_Mapping : aliased constant S := "/MAPPING_FILE=<" & - "-gnatem>"; - -- /MAPPING_FILE=file_name - -- - -- Use mapping file file_name - -- - -- A mapping file is a way to communicate to the compiler two mappings: - -- from unit names to file names (without any directory information) and - -- from file names to path names (with full directory information). - -- These mappings are used by the compiler to short-circuit the path - -- search. - -- - -- The use of mapping files is not required for correct operation of the - -- compiler, but mapping files can improve efficiency, particularly when - -- sources are read over a slow network connection. In normal operation, - -- you need not be concerned with the format or use of mapping files, - -- and /MAPPING_FILE is not a qualifier that you would use explicitly. - -- It is intended only for use by automatic tools such as GNAT MAKE - -- running under the project file facility. The description here of the - -- format of mapping files is provided for completeness and for possible - -- use by other tools. - -- - -- A mapping file is a sequence of sets of three lines. In each set, the - -- first line is the unit name, in lower case, with "%s" appended for - -- specifications and "%b" appended for bodies; the second line is the - -- file name; and the third line is the path name. - -- - -- Example: - -- - -- main%b - -- main.2_ada - -- /gnat/project1/sources/main.2_ada - -- - -- When qualifier ?MAPPING_FILE is specified, the compiler will create in - -- memory the two mappings from the specified file. If there is any - -- problem (non existent file, truncated file or duplicate entries), - -- no mapping will be created. - -- - -- Several /MAPPING_FILE qualifiers may be specified; however, only the - -- last one on the command line will be taken into account. - -- - -- When using a project file, GNAT MAKE creates a temporary mapping file - -- and communicates it to the compiler using this switch. - - S_GCC_MaxI : aliased constant S := "/MAX_INSTANTIATIONS=#" & - "-gnatei#"; - - -- /MAX_INSTANTIATIONS=nnn - -- - -- Specify the maximum number of instantiations permitted. The default - -- value is 8000, which is probably enough for all programs except those - -- containing some kind of runaway unintended instantiation loop. - - S_GCC_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_GCC_Multi : aliased constant S := "/MULTI_UNIT_INDEX=#" & - "-gnateI#"; - -- /MULTI_UNIT_INDEX=nnn - -- - -- Specify the index of the unit to compile in a multi-unit source file. - - S_GCC_Nesting : aliased constant S := "/MAX_NESTING=#" & - "-gnatyL#"; - -- /MAX_NESTING=nnn - -- - -- Set maximum level of nesting of constructs (including subprograms, - -- loops, blocks, packages, and conditionals). - -- The level of nesting must not exceed the given value nnn. - -- A value of zero disable this style check (not enabled by default). - - S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " & - "-gnatA"; - -- /NO_GNAT_ADC - -- - -- Cause the compiler to ignore any configuration pragmas file GNAT.ADC - -- in the default directory. Implied by qualifier /PROJECT_FILE. - -- Often used in conjunction with qualifier /CONFIGURATION_PRAGMAS_FILE. - - S_GCC_Noload : aliased constant S := "/NOLOAD " & - "-gnatc"; - -- /NOLOAD - -- - -- Cause the compiler to operate in semantic check mode with full - -- checking for all illegalities specified in the reference manual, but - -- without generation of any source code (no object or ALI file - -- generated). - -- - -- Since dependent files must be accessed, you must follow the GNAT - -- semantic restrictions on file structuring to operate in this mode: - -- - -- o The needed source files must be accessible. - -- o Each file must contain only one compilation unit. - -- o The file name and unit name must match. - -- - -- The output consists of error messages as appropriate. No object file - -- or ALI file is generated. The checking corresponds exactly to the - -- notion of legality in the Ada reference manual. - -- - -- Any unit can be compiled in semantics-checking-only mode, including - -- units that would not normally be compiled (generic library units, - -- subunits, and specifications where a separate body is present). - - S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; - -- /NOSTD_INCLUDES - -- - -- Do not look in the default directory for source files of the runtime. - - S_GCC_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & - "-nostdlib"; - -- /NOSTD_LIBRARIES - -- - -- Do not look for library files in the system default directory. - - S_GCC_NoWarnP : aliased constant S := "/NOWARNING_PRAGMAS " & - "-gnatd.i"; - -- /NOWARNING_PRAGMAS - -- - -- Causes all Warnings pragmas to be ignored. Useful to check if the - -- program has obsolete warnings pragmas that are hiding problems. - - S_GCC_Opt : aliased constant S := "/OPTIMIZE=" & - "ALL " & - "-O2,!-O0,!-O1,!-O3 " & - "NONE " & - "-O0,!-O1,!-O2,!-O3 " & - "SOME " & - "-O1,!-O0,!-O2,!-O3 " & - "SPACE " & - "-Os,!-O0,!-O1,!-O2,!-O3 " & - "DEVELOPMENT " & - "-O1,!-O0,!-O2,!-O3 " & - "UNROLL_LOOPS " & - "-funroll-loops " & - "NO_STRICT_ALIASING " & - "-fno-strict-aliasing " & - "INLINING " & - "-O3,!-O0,!-O1,!-O2"; - -- /NOOPTIMIZE (D) - -- /OPTIMIZE[=(keyword[,...])] - -- - -- Selects the level of optimization for your program. The supported - -- keywords are as follows: - -- - -- ALL (D) Perform most optimizations, including those that - -- may be expensive. - -- - -- NONE Do not do any optimizations. Same as /NOOPTIMIZE. - -- - -- SOME Perform some optimizations, but omit ones that - -- are costly in compilation time. - -- - -- SPACE Optimize space usage - -- - -- DEVELOPMENT Same as SOME. - -- - -- INLINING Full optimization, and also attempt automatic inlining - -- of small subprograms within a unit - -- - -- UNROLL_LOOPS Try to unroll loops. This keyword may be specified - -- with any keyword above other than NONE. Loop - -- unrolling usually, but not always, improves the - -- performance of programs. - -- - -- NO_STRICT_ALIASING - -- Suppress aliasing analysis. When optimization is - -- enabled (ALL or SOME above), the compiler assumes - -- that pointers do in fact point to legitimate values - -- of the pointer type (allocated from the proper pool). - -- If this assumption is violated, e.g. by the use of - -- unchecked conversion, then it may be necessary to - -- suppress this assumption using this keyword (which - -- may be specified only in conjunction with any - -- keyword above, other than NONE). - - S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " & - "-O0,!-O1,!-O2,!-O3"; - -- NODOC (see /OPTIMIZE) - - S_GCC_Output : aliased constant S := "/OUTPUT_FILE=<" & - "-gnatl=>"; - -- /OUTPUT_FILE=fname - -- - -- This has the same effect as /LIST except that the output is written - -- to a file instead of to standard output. If the given fname - -- does not start with a period, then it is the full name of the file - -- to be written. If fname starts with a period, the name of the file - -- is the concatenation of to the name of the file being compiled with - -- fname where the period is replace by an underline. For example, if - -- file xyz.adb is compiled with -gnatl=.lst, then the output is written - -- to file xyz.adb_lst. - - S_GCC_Overflo : aliased constant S := "/OVERFLOW_CHECKS=#" & - "-gnato#"; - -- /OVERFLOW_CHECKS=nn - -- - -- Set default overflow cheecking mode. If nn is a single digit, in the - -- range 0-3, it sets the overflow checking mode for all expressions, - -- including those outside and within assertions. The meaning of nnn is: - -- - -- 1 all intermediate computations done using base type (STRICT) - -- 2 minimize intermediate overflows (MINIMIZED) - -- 3 eliminate intermediate overflows (ELIMINATED) - -- - -- Otherwise nn can be two digits, both 1-3, and in this case the first - -- digit sets the mode (using the above code) for expressions outside an - -- assertion, and the second digit sets the mode for expressions within - -- an assertion. - - S_GCC_PValid : aliased constant S := "/PARAMETER_VALIDITY_CHECK " & - "-gnateV"; - -- /NOPARAMETER_VALIDITY_CHECK (D) - -- /PARAMETER_VALIDITY_CHECK - -- - -- Check validity of subprogram parameters. - - S_GCC_Pointer : aliased constant S := "/POINTER_SIZE=" & - "64 " & - "-mmalloc64 " & - "LONG " & - "-mmalloc64 " & - "32 " & - "-mno-malloc64 " & - "SHORT " & - "-mno-malloc64"; - -- /POINTER_SIZE=64 (D) - -- /POINTER_SIZE[=(keyword[,...])] - -- - -- Change how pointers and descriptors are allocated. The following - -- keywords are supported: - -- - -- 64 (D) Allocate heap pointers in 64bit space except as - -- constrained by a 32bit size clause or by - -- Convention_C and generate 64bit descriptors for - -- Descriptor mechanisms for calling imported - -- subprograms and accept both 64bit and 32bit - -- descriptors for calls to exported subprograms. - -- - -- LONG Equivalent to option 64. - -- - -- 32 Allocate all heap pointers in 32bit space and - -- generate 32bit descriptors for Descriptor - -- mechanisms for calling imported subprograms. - -- - -- SHORT Equivalent to option 32. - - S_GCC_Polling : aliased constant S := "/POLLING " & - "-gnatP"; - -- /NOPOLLING (D) - -- /POLLING - -- - -- Enable polling. See the description of pragma Polling in the GNAT - -- Reference Manual for full details. - - S_GCC_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- compiler. The source and object directories to be searched will be - -- communicated to the compiler through logical names - -- ADA_PRJ_INCLUDE_FILE and ADA_PRJ_OBJECTS_FILE. - - S_GCC_Psta : aliased constant S := "/PRINT_STANDARD " & - "-gnatS"; - -- /PRINT_STANDARD - -- - -- cause the compiler to output a representation of package Standard - -- in a form very close to standard Ada. It is not quite possible to - -- do this and remain entirely Standard (since new numeric base types - -- cannot be created in standard Ada), but the output is easily - -- readable to any Ada programmer, and is useful to determine the - -- characteristics of target dependent types in package Standard. - - S_GCC_Reswarn : aliased constant S := "/TREAT_RESTRICTIONS_AS_WARNINGS " & - "-gnatr"; - - -- /NO_TREAT_RESTRICTIONS_AS_WARNINGS (D) - -- /TREAT_RESTRICTIONS_AS_WARNINGS - -- - -- Causes all restrictions to be treated as warnings (pragma Restriction - -- treated as Restriction_Warnings, pragma Profile as Profile_Warnings, - -- and pragma Ravenscar sets restriction warnings instead of restrictions) - - S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" & - "VERBOSE " & - "-gnatv " & - "BRIEF " & - "-gnatb " & - "FULL " & - "-gnatf " & - "IMMEDIATE " & - "-gnatdO " & - "DEFAULT " & - "!-gnatb,!-gnatv"; - -- /NOREPORT_ERRORS (D) - -- /REPORT_ERRORS[=(keyword[,...])] - -- - -- Change the way errors are reported. The following keywords are - -- supported: - -- - -- VERBOSE (D) Verbose mode. Full error output with source lines - -- to SYS$OUTPUT. - -- - -- BRIEF Generate the brief format error messages to - -- SYS$OUTPUT as well as the verbose format message or - -- full listing. - -- - -- FULL Normally, the compiler suppresses error messages that - -- are likely to be redundant. This keyword causes all - -- error messages to be generated. One particular effect - -- is for the case of references to undefined variables. - -- If a given variable is referenced several times, the - -- normal format of messages produces one error. With - -- FULL, each undefined reference produces a separate - -- error message. - -- - -- IMMEDIATE Normally, the compiler saves up error messages and - -- generates them at the end of compilation in proper - -- sequence. This keyword causes error messages to be - -- generated as soon as they are detected. The use of - -- IMMEDIATE usually causes error messages to be - -- generated out of sequence. Use it when the compiler - -- blows up due to an internal error. In this case, the - -- error messages may be lost. Sometimes blowups are - -- the result of mishandled error messages, so you may - -- want to run with this keyword to determine whether - -- any error messages were generated. - -- - -- DEFAULT Turn off VERBOSE and BRIEF. Same as /NOREPORT_ERRORS. - - S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " & - "!-gnatb,!-gnatv"; - -- NODOC (see /REPORT_ERRORS) - - S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" & - "DEFAULT " & - "-gnatR " & - "NONE " & - "-gnatR0 " & - "ARRAYS " & - "-gnatR1 " & - "ARRAYS_FILE " & - "-gnatR1s " & - "OBJECTS " & - "-gnatR2 " & - "OBJECTS_FILE " & - "-gnatR2s " & - "SYMBOLIC " & - "-gnatR3 " & - "SYMBOLIC_FILE " & - "-gnatR3s " & - "MECHANISMS " & - "-gnatRm " & - "MECHANISMS_FILE " & - "-gnatRms"; - -- /NOREPRESENTATION_INFO (D) - -- /REPRESENTATION_INFO[=(keyword[,...])] - -- - -- This qualifier controls output from the compiler of a listing showing - -- representation information for declared types and objects. - -- - -- ARRAYS (D) Size and alignment information is listed for - -- declared array and record types. - -- - -- ARRAYS_FILE Similar to ARRAYS, but the output is to a file - -- with the name 'file_rep' where 'file' is the name - -- of the corresponding source file. - -- - -- NONE no information is output (equivalent to omitting - -- the /REPRESENTATION_INFO qualifiers). - -- - -- OBJECTS Size and alignment information is listed for all - -- declared types and objects. - -- - -- OBJECTS_FILE Similar to OBJECTS, but the output is to a file - -- with the name 'file_rep' where 'file' is the name - -- of the corresponding source file. - -- - -- SYMBOLIC Symbolic expression information for values that - -- are computed at run time for variant records. - -- - -- SYMBOLIC_FILE Similar to SYMBOLIC, but the output is to a file - -- with the name 'file_rep' where 'file' is the name - -- of the corresponding source file. - -- - -- MECHANISMS List convention and argument passing mechanisms - -- for all subprograms - -- - -- MECHANISMS_FILE Similar to MECHANISMS, but the output is to a file - -- with the name 'file_rep' where file is the name - -- of the corresponding source file. - -- - -- DEFAULT Equivalent to ARRAYS. - - S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " & - "!-gnatR"; - -- NODOC (see /REPRESENTATION_INFO) - - S_GCC_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & - "--RTS=|"; - -- /RUNTIME_SYSTEM=xxx - -- - -- Build against an alternate runtime system named xxx or RTS-xxx. - - S_GCC_SCO : aliased constant S := "/SCO_OUTPUT " & - "-gnateS"; - -- /NOSCO_OUTPUT (D) - -- /SCO_OUTPUT - -- - -- Controls the output of SCO (Source Coverage Obligation) information - -- in the generated ALI file. This information is used by advanced source - -- coverage tools. For a full description of the SCO format, see unit - -- SCOs in the compiler sources (sco.ads/sco.adb). - - S_GCC_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory[,...]) - -- - -- When looking for source files also look in directories specified. - - S_GCC_Src_Info : aliased constant S := "/SRC_INFO=<" & - "--source-info=>"; - -- /SRC_INFO=source-info-file - -- - -- Specify a source info file to be read or written by the Project - -- Manager when project files are used. - - S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" & - "ALL_BUILTIN " & - "-gnatyy " & - "0 " & - "-gnaty0 " & - "1 " & - "-gnaty1 " & - "2 " & - "-gnaty2 " & - "3 " & - "-gnaty3 " & - "4 " & - "-gnaty4 " & - "5 " & - "-gnaty5 " & - "6 " & - "-gnaty6 " & - "7 " & - "-gnaty7 " & - "8 " & - "-gnaty8 " & - "9 " & - "-gnaty9 " & - "ATTRIBUTE " & - "-gnatya " & - "NOATTRIBUTE " & - "-gnaty-a " & - "ARRAY_INDEXES " & - "-gnatyA " & - "NOARRAY_INDEXES " & - "-gnaty-A " & - "BLANKS " & - "-gnatyb " & - "NOBLANKS " & - "-gnaty-b " & - "BOOLEAN_OPERATORS " & - "-gnatyB " & - "NOBOOLEAN_OPERATORS " & - "-gnaty-B " & - "COMMENTS " & - "-gnatyc " & - "COMMENTS1 " & - "-gnatyC " & - "COMMENTS2 " & - "-gnatyc " & - "NOCOMMENTS " & - "-gnaty-c " & - "DOS_LINE_ENDINGS " & - "-gnatyd " & - "NODOS_LINE_ENDINGS " & - "-gnaty-d " & - "END " & - "-gnatye " & - "NOEND " & - "-gnaty-e " & - "VTABS " & - "-gnatyf " & - "NOVTABS " & - "-gnaty-f " & - "GNAT " & - "-gnatyg " & - "HTABS " & - "-gnatyh " & - "NOHTABS " & - "-gnaty-h " & - "IF_THEN " & - "-gnatyi " & - "NOIF_THEN " & - "-gnaty-i " & - "KEYWORD " & - "-gnatyk " & - "NOKEYWORD " & - "-gnaty-k " & - "LAYOUT " & - "-gnatyl " & - "NOLAYOUT " & - "-gnaty-l " & - "LINE_LENGTH " & - "-gnatym " & - "NOLINE_LENGTH " & - "-gnaty-m " & - "MODE_IN " & - "-gnatyI " & - "NOMODE_IN " & - "-gnaty-I " & - "NONE " & - "-gnatyN " & - "STANDARD_CASING " & - "-gnatyn " & - "NOSTANDARD_CASING " & - "-gnaty-n " & - "ORDERED_SUBPROGRAMS " & - "-gnatyo " & - "NOORDERED_SUBPROGRAMS " & - "-gnaty-o " & - "OVERRIDING_INDICATORS " & - "-gnatyO " & - "NOOVERRIDING_INDICATORS " & - "-gnaty-O " & - "PRAGMA " & - "-gnatyp " & - "NOPRAGMA " & - "-gnaty-p " & - "REFERENCES " & - "-gnatyr " & - "NOREFERENCES " & - "-gnaty-r " & - "SPECS " & - "-gnatys " & - "NOSPECS " & - "-gnaty-s " & - "STATEMENTS_AFTER_THEN_ELSE " & - "-gnatyS " & - "NOSTATEMENTS_AFTER_THEN_ELSE " & - "-gnaty-S " & - "TOKEN " & - "-gnatyt " & - "NOTOKEN " & - "-gnaty-t " & - "UNNECESSARY_BLANK_LINES " & - "-gnatyu " & - "NOUNNECESSARY_BLANK_LINES " & - "-gnaty-u " & - "XTRA_PARENS " & - "-gnaty-x " & - "NOXTRA_PARENS " & - "-gnaty-x"; - -- /NOSTYLE_CHECKS (D) - -- /STYLE_CHECKS[=(keyword,[...])] - -- - -- Normally, GNAT permits any code layout consistent with the reference - -- manual requirements. This qualifier imposes style checking on the - -- input source code. The following keywords are supported: - -- - -- ALL_BUILTIN (D) Equivalent to the following list of options: - -- 3, ATTRIBUTE, BLANKS, COMMENTS2, END, VTABS, - -- HTABS, IF_THEN, KEYWORD, LAYOUT, LINE_LENGTH, - -- PRAGMA, REFERENCES, SPECS, TOKEN. - -- - -- 1 .. 9 Specify indentation level from 1 to 9. - -- The general style of required indentation is as - -- specified by the examples in the Ada Reference - -- Manual. Full line comments must be aligned with - -- the -- starting on a column that is a multiple - -- of the alignment level. - -- - -- ATTRIBUTE Check attribute casing. - -- Attribute names, including the case of keywords - -- such as digits used as attributes names, - -- must be written in mixed case, that is, - -- the initial letter and any letter following an - -- underscore must be uppercase. - -- All other letters must be lowercase. - -- - -- ARRAY_INDEXES Check indexes of array attributes. - -- For array attributes First, Last, Range, - -- or Length, the index number must be omitted - -- for one-dimensional arrays and is required - -- for multi-dimensional arrays. - -- - -- BLANKS Blanks not allowed at statement end. - -- Trailing blanks are not allowed at the end of - -- statements. The purpose of this rule, together - -- with option HTABS (no horizontal tabs), is to - -- enforce a canonical format for the use of - -- blanks to separate source tokens. - -- - -- COMMENTS2 Check comments. - -- COMMENTS Comments must meet the following set of rules: - -- - -- * The "--" that starts the column must either - -- start in column one, or else at least one - -- blank must precede this sequence. - -- - -- * Comments that follow other tokens on a line - -- must have at least one blank following the - -- "--" at the start of the comment. - -- - -- * Full line comments must have two blanks - -- following the "--" that starts the comment, - -- with the following exceptions. - -- - -- * A line consisting only of the "--" - -- characters, possibly preceded by blanks is - -- permitted. - -- - -- * A comment starting with "--x" where x is - -- a special character is permitted. This - -- allows proper processing of the output - -- generated by specialized tools including - -- gnatprep (where --! is used) and the SPARK - -- annotation language (where --# is used). - -- For the purposes of this rule, a special - -- character is defined as being in one of the - -- ASCII ranges 16#21#..16#2F# or - -- 16#3A#..16#3F#. - -- - -- * A line consisting entirely of minus signs, - -- possibly preceded by blanks, is permitted. - -- This allows the construction of box - -- comments where lines of minus signs are - -- used to form the top and bottom of the box. - -- - -- * If a comment starts and ends with "--" is - -- permitted as long as at least one blank - -- follows the initial "--". Together with - -- the preceding rule, this allows the - -- construction of box comments, as shown in - -- the following example: - -- - -- --------------------------- - -- -- This is a box comment -- - -- --------------------------- - -- - -- COMMENTS1 Check comments (single space). - -- Like COMMENTS2, but the -- of a comment only - -- requires one or more spaces following, instead - -- of two or more spaces. - -- - -- DOS_LINE_ENDINGS Check that no DOS line terminators are present - -- All lines must be terminated by a single - -- ASCII.LF character. In particular the DOS line - -- terminator sequence CR / LF is not allowed). - -- - -- END Check end/exit labels. - -- Optional labels on end statements ending - -- subprograms and on exit statements exiting - -- named loops, are required to be present. - -- - -- GNAT Enforces a set of style conventions that - -- match the style used in the GNAT source code. - -- This maybe useful when developing code that - -- is eventually intended to be incorporated into - -- GNAT. For further details, see GNAT sources. - -- - -- HTABS No horizontal tabs. - -- Horizontal tab characters are not permitted in - -- the source text. Together with the BLANKS - -- (no blanks at end of line) option, this - -- enforces a canonical form for the use of blanks - -- to separate source tokens. - -- - -- IF_THEN Check if-then layout. - -- The keyword then must appear either on the - -- same line as the corresponding if, or on a line - -- on its own, lined up under the if with at least - -- one non-blank line in between containing all or - -- part of the condition to be tested. - -- - -- KEYWORD Check keyword casing. - -- All keywords must be in lower case (with the - -- exception of keywords such as digits used as - -- attribute names to which this check does not - -- apply). - -- - -- LAYOUT Check layout. - -- Layout of statement and declaration constructs - -- must follow the recommendations in the Ada - -- Reference Manual, as indicated by the form of - -- the syntax rules. For example an else keyword - -- must be lined up with the corresponding if - -- keyword. - -- - -- There are two respects in which the style rule - -- enforced by this check option are more liberal - -- than those in the Ada Reference Manual. - -- First in the case of record declarations, - -- it is permissible to put the record keyword on - -- the same line as the type keyword, and then - -- the end in end record must line up under type. - -- For example, either of the following two - -- layouts is acceptable: - -- - -- type q is record - -- a : integer; - -- b : integer; - -- end record; - -- - -- type q is - -- record - -- a : integer; - -- b : integer; - -- end record; - -- - -- Second, in the case of a block statement, - -- a permitted alternative is to put the block - -- label on the same line as the declare or begin - -- keyword, and then line the end keyword up under - -- the block label. For example both the following - -- are permitted: - -- - -- - -- - -- Block : declare - -- A : Integer := 3; - -- begin - -- Proc (A, A); - -- end Block; - -- - -- Block : - -- declare - -- A : Integer := 3; - -- begin - -- Proc (A, A); - -- end Block; - -- - -- The same alternative format is allowed for - -- loops. For example, both of the following are - -- permitted: - -- - -- - -- - -- Clear : while J < 10 loop - -- A (J) := 0; - -- end loop Clear; - -- - -- Clear : - -- while J < 10 loop - -- A (J) := 0; - -- end loop Clear; - -- - -- - -- - -- LINE_LENGTH Check maximum line length. - -- The length of source lines must not exceed 79 - -- characters, including any trailing blanks - -- The value of 79 allows convenient display on - -- an 80 character wide device or window, allowing - -- for possible special treatment of 80 character - -- lines. - -- - -- NONE Clear any previously set style checks. - -- - -- ORDERED_SUBPROGRAMS Check order of subprogram bodies. - -- All subprogram bodies in a given scope (e.g. - -- a package body) must be in alphabetical order. - -- The ordering rule uses normal Ada rules for - -- comparing strings, ignoring casing of letters, - -- except that if there is a trailing numeric - -- suffix, then the value of this suffix is used - -- in the ordering (e.g. Junk2 comes before - -- Junk10). - -- - -- OVERRIDING_INDICATORS Check that overriding subprograms are - -- explicitly marked as such. The declaration of - -- a primitive operation of a type extension that - -- overrides an inherited operation must carry - -- an overriding indicator. - -- - -- PRAGMA Check pragma casing. - -- Pragma names must be written in mixed case, - -- that is, the initial letter and any letter - -- following an underscore must be uppercase. - -- All other letters must be lowercase. - -- - -- REFERENCES Check references. - -- All identifier references must be cased in the - -- same way as the corresponding declaration. - -- No specific casing style is imposed on - -- identifiers. The only requirement is for - -- consistency of references with declarations. - -- - -- SPECS Check separate specs. - -- Separate declarations ("specs") are required - -- for subprograms (a body is not allowed to serve - -- as its own declaration). The only exception is - -- that parameterless library level procedures are - -- not required to have a separate declaration. - -- This exception covers the most frequent form of - -- main program procedures. - -- - -- STANDARD_CASING Check casing of entities in Standard. - -- Any identifier from Standard must be cased to - -- match the presentation in the Ada Reference - -- Manual (for example, Integer and ASCII.NUL). - -- - -- TOKEN Check token spacing. - -- The following token spacing rules are enforced: - -- - -- * The keywords abs and not must be followed - -- by a space. - -- - -- * The token => must be surrounded by spaces. - -- - -- * The token <> must be preceded by a space or - -- a left parenthesis. - -- - -- * Binary operators other than ** must be - -- surrounded by spaces. There is no - -- restriction on the layout of the ** binary - -- operator. - -- - -- * Colon must be surrounded by spaces. - -- - -- * Colon-equal (assignment) must be surrounded - -- by spaces. - -- - -- * Comma must be the first non-blank character - -- on the line, or be immediately preceded by - -- a non-blank character, and must be followed - -- by a space. - -- - -- * If the token preceding a left paren ends - -- with a letter or digit, then a space must - -- separate the two tokens. - -- - -- * A right parenthesis must either be the - -- first non-blank character on a line, or it - -- must be preceded by a non-blank character. - -- - -- * A semicolon must not be preceded by - -- a space, and must not be followed by - -- a non-blank character. - -- - -- * A unary plus or minus may not be followed - -- by a space. - -- - -- * A vertical bar must be surrounded by - -- spaces. - -- - -- In the above rules, appearing in column one is - -- always permitted, that is, counts as meeting - -- either a requirement for a required preceding - -- space, or as meeting a requirement for no - -- preceding space. - -- - -- Appearing at the end of a line is also always - -- permitted, that is, counts as meeting either - -- a requirement for a following space, - -- or as meeting a requirement for no following - -- space. - -- - -- UNNECESSARY_BLANK_LINES - -- Check for unnecessary blank lines. - -- A blank line is considered unnecessary if it - -- appears at the end of the file, or if more - -- than one blank line occurs in sequence. - -- - -- VTABS No form feeds or vertical tabs. - -- Form feeds or vertical tab characters are not - -- permitted in the source text. - -- - -- XTRA_PARENS Check for the use of an unnecessary extra - -- level of parentheses (C - style) around - -- conditions in if statements, while statements - -- and exit statements. - - S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " & - "!-gnatg,!-gnaty*"; - -- NODOC (see /STYLE_CHECKS) - - S_GCC_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_GCC_Symbol : aliased constant S := "/SYMBOL_PREPROCESSING=" & '"' & - "-gnateD" & '"'; - -- /SYMBOL_PREPROCESSING="symbol=value" - -- - -- Define or redefine a preprocessing symbol, associated with value. - -- If "=value" is not specified, then the value of the symbol is True. - -- A symbol is an identifier, following normal Ada (case-insensitive) - -- rules for its syntax, and value is any sequence (including an empty - -- sequence) of characters from the set (letters, digits, period, - -- underline). Ada reserved words may be used as symbols, with the - -- exceptions of "if", "else", "elsif", "end", "and", "or" and "then". - -- - -- A symbol declared with this qualifier on the command line replaces - -- a symbol with the same name either in a definition file or specified - -- with a switch -D in the preprocessor data file. - -- - -- This qualifier is similar to qualifier /ASSOCIATE of - -- GNAT PREPROCESSING. - - S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " & - "-gnats"; - -- /NOSYNTAX_ONLY (D) - -- /SYNTAX_ONLY - -- - -- Run GNAT in syntax checking only mode. You can check a series of - -- files in a single command, and can use wild cards to specify such a - -- group of files. - -- - -- You may use other qualifiers in conjunction with this qualifier. In - -- particular, /LIST and /REPORT_ERRORS=VERBOSE are useful to control the - -- format of any generated error messages. - -- - -- The output is simply the error messages, if any. No object file or ALI - -- file is generated by a syntax-only compilation. Also, no units other - -- than the one specified are accessed. For example, if a unit "X" with's - -- a unit "Y", compiling unit "X" in syntax check only mode does not - -- access the source file containing unit "Y". - -- - -- 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 GNAT CHOP - -- command. - - S_GCC_Table : aliased constant S := "/TABLE_MULTIPLIER=#" & - "-gnatT#"; - -- /TABLE_MULTIPLIER=nnn - -- - -- All compiler tables start at nnn times usual starting size. - - S_GCC_Target_W : aliased constant S := "/WRITE_TARGET_DEPENDENT_INFO=<" & - "-gnatet=>"; - -- /WRITE_TARGET_DEPENDENT_INFO=file - -- - -- Generate target dependent information to file. - - S_GCC_Target_R : aliased constant S := "/READ_TARGET_DEPENDENT_INFO=<" & - "-gnateT=>"; - -- /READ_TARGET_DEPENDENT_INFO=file - -- - -- Read target dependent information from file. - - S_GCC_Trace : aliased constant S := "/TRACE_UNITS " & - "-gnatdc"; - -- /TRACE_UNITS - -- /NOTRACE_UNITS - -- - -- This switch that does for the frontend what /VERBOSE does for the - -- backend. The system prints the name of each unit, either a compilation - -- unit or nested unit, as it is being analyzed. - - S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " & - "-gnatt"; - -- /TREE_OUTPUT - -- /NOTREE_OUTPUT - -- - -- Cause GNAT to write the internal tree for a unit to a file (with the - -- filetype ATB for a body or ATS for a spec). This is not normally - -- required, but is used by separate analysis tools. Typically these - -- tools do the necessary compilations automatically, so you should never - -- have to specify this switch in normal operation. - - S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " & - "-gnatq"; - -- /TRY_SEMANTICS - -- /NOTRY_SEMANTICS - -- - -- In normal operation mode the compiler first parses the program and - -- determines if there are any syntax errors. If there are, appropriate - -- error messages are generated and compilation is immediately - -- terminated. This qualifier tells GNAT to continue with semantic - -- analysis even if syntax errors have been found. This may enable the - -- detection of more errors in a single run. On the other hand, the - -- semantic analyzer is more likely to encounter some internal fatal - -- error when given a syntactically invalid tree. - - S_GCC_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & - "--unchecked-shared-lib-imports"; - -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) - -- /UNCHECKED_SHARED_LIB_IMPORTS - -- - -- Allow shared library projects to import static library projects - - S_GCC_Units : aliased constant S := "/UNITS_LIST " & - "-gnatu"; - -- /NOUNITS_LIST (D) - -- /UNITS_LIST - -- - -- Print a list of units required by this compilation on SYS$OUTPUT. The - -- listing includes all units on which the unit being compiled depends - -- either directly or indirectly. - - S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " & - "-gnatU"; - -- /NOUNIQUE_ERROR_TAG (D) - -- /UNIQUE_ERROR_TAG - -- - -- Tag compiler error messages with the string "error: ". - - S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " & - "-gnatF"; - -- /NOUPPERCASE_EXTERNALS (D) - -- /UPPERCASE_EXTERNALS - -- - -- Fold default and explicit external names in pragmas Import and Export - -- to uppercase for compatibility with the default behavior of DEC C. - - S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" & - "DEFAULT " & - "-gnatVd " & - "NODEFAULT " & - "-gnatVD " & - "COPIES " & - "-gnatVc " & - "NOCOPIES " & - "-gnatVC " & - "COMPONENTS " & - "-gnatVe " & - "NOCOMPONENTS " & - "-gnatVE " & - "FLOATS " & - "-gnatVf " & - "NOFLOATS " & - "-gnatVF " & - "IN_PARAMS " & - "-gnatVi " & - "NOIN_PARAMS " & - "-gnatVI " & - "MOD_PARAMS " & - "-gnatVm " & - "NOMOD_PARAMS " & - "-gnatVM " & - "OPERANDS " & - "-gnatVo " & - "NOOPERANDS " & - "-gnatVO " & - "PARAMETERS " & - "-gnatVp " & - "NOPARAMETERS " & - "-gnatVP " & - "RETURNS " & - "-gnatVr " & - "NORETURNS " & - "-gnatVR " & - "SUBSCRIPTS " & - "-gnatVs " & - "NOSUBSCRIPTS " & - "-gnatVS " & - "TESTS " & - "-gnatVt " & - "NOTESTS " & - "-gnatVT " & - "ALL " & - "-gnatVa " & - "NONE " & - "-gnatVn"; - -- /VALIDITY_CHECKING[=(keyword,[...])] - -- - -- Control level of validity checking. - -- - -- DEFAULT (D) In this mode checks are made to prevent - -- erroneous behavior in accordance with the RM. - -- Notably extra checks may be needed for case - -- statements and subscripted array assignments. - -- - -- NONE No special checks for invalid values are - -- performed. This means that references to - -- uninitialized variables can cause erroneous - -- behavior from constructs like case statements - -- and subscripted array assignments. In this - -- mode, invalid values can lead to erroneous - -- behavior. - -- - -- FULL Every assignment is checked for validity, so - -- that it is impossible to assign invalid values. - -- The RM specifically allows such assignments, - -- but in this mode, invalid values can never be - -- assigned, and an attempt to perform such an - -- assignment immediately raises Constraint_Error. - -- This behavior is allowed (but not required) by - -- the RM. This mode is intended as a debugging aid, - -- and may be useful in helping to track down - -- uninitialized variables. It may be useful to - -- use this in conjunction with the Normalize_Scalars - -- pragma which attempts to initialize with invalid - -- values where possible. - - S_GCC_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /VERBOSE - -- /NOVERBOSE - -- - -- Show commands generated by the GCC driver. Normally used only for - -- debugging purposes or if you need to be sure what version of the - -- compiler you are executing. - - S_GCC_Verb_Asm : aliased constant S := "/VERBOSE_ASM " & - "-S,-verbose_asm,!-c"; - -- /NOASM (D) - -- /ASM - -- - -- Use to cause the assembler source file to be generated, using S as the - -- filetype, instead of the object file. This may be useful if you need - -- to examine the generated assembly code. - - S_GCC_Warn : aliased constant S := "/WARNINGS=" & - "DEFAULT " & - "!-gnatws,!-gnatwe " & - "ALL " & - "-gnatwa " & - "EVERY " & - "-gnatw.e " & - "OPTIONAL " & - "-gnatwa " & - "NOOPTIONAL " & - "-gnatwA " & - "NOALL " & - "-gnatwA " & - "ALL_GCC " & - "-Wall " & - "FAILING_ASSERTIONS " & - "-gnatw.a " & - "NO_FAILING_ASSERTIONS " & - "-gnatw.A " & - "BAD_FIXED_VALUES " & - "-gnatwb " & - "NO_BAD_FIXED_VALUES " & - "-gnatwB " & - "BIASED_REPRESENTATION " & - "-gnatw.b " & - "NO_BIASED_REPRESENTATION " & - "-gnatw.B " & - "CONDITIONALS " & - "-gnatwc " & - "NOCONDITIONALS " & - "-gnatwC " & - "MISSING_COMPONENT_CLAUSES " & - "-gnatw.c " & - "NOMISSING_COMPONENT_CLAUSES " & - "-gnatw.C " & - "IMPLICIT_DEREFERENCE " & - "-gnatwd " & - "NO_IMPLICIT_DEREFERENCE " & - "-gnatwD " & - "TAG_WARNINGS " & - "-gnatw.d " & - "NOTAG_WARNINGS " & - "-gnatw.D " & - "ERRORS " & - "-gnatwe " & - "UNREFERENCED_FORMALS " & - "-gnatwf " & - "NOUNREFERENCED_FORMALS " & - "-gnatwF " & - "UNRECOGNIZED_PRAGMAS " & - "-gnatwg " & - "NOUNRECOGNIZED_PRAGMAS " & - "-gnatwG " & - "HIDING " & - "-gnatwh " & - "NOHIDING " & - "-gnatwH " & - "AVOIDGAPS " & - "-gnatw.h " & - "NOAVOIDGAPS " & - "-gnatw.H " & - "IMPLEMENTATION " & - "-gnatwi " & - "NOIMPLEMENTATION " & - "-gnatwI " & - "OVERLAPPING_ACTUALS " & - "-gnatw.i " & - "NOOVERLAPPING_ACTUALS " & - "-gnatw.I " & - "OBSOLESCENT " & - "-gnatwj " & - "NOOBSOLESCENT " & - "-gnatwJ " & - "CONSTANT_VARIABLES " & - "-gnatwk " & - "NOCONSTANT_VARIABLES " & - "-gnatwK " & - "STANDARD_REDEFINITION " & - "-gnatw.k " & - "NOSTANDARD_REDEFINITION " & - "-gnatw.K " & - "ELABORATION " & - "-gnatwl " & - "NOELABORATION " & - "-gnatwL " & - "INHERITED_ASPECTS " & - "-gnatw.l " & - "NOINHERITED_ASPECTS " & - "-gnatw.L " & - "MODIFIED_UNREF " & - "-gnatwm " & - "NOMODIFIED_UNREF " & - "-gnatwM " & - "SUSPICIOUS_MODULUS " & - "-gnatw.m " & - "NOSUSPICIOUS_MODULUS " & - "-gnatw.M " & - "NORMAL " & - "-gnatwn " & - "ATOMIC_SYNCHRONIZATION " & - "-gnatw.n " & - "NOATOMIC_SYNCHRONIZATION " & - "-gnatw.N " & - "OVERLAYS " & - "-gnatwo " & - "NOOVERLAYS " & - "-gnatwO " & - "OUT_PARAM_UNREF " & - "-gnatw.o " & - "NOOUT_PARAM_UNREF " & - "-gnatw.O " & - "INEFFECTIVE_INLINE " & - "-gnatwp " & - "NOINEFFECTIVE_INLINE " & - "-gnatwP " & - "PARAMETER_ORDER " & - "-gnatw.p " & - "NOPARAMETER_ORDER " & - "-gnatw.P " & - "MISSING_PARENS " & - "-gnatwq " & - "NOMISSING_PARENS " & - "-gnatwQ " & - "REDUNDANT " & - "-gnatwr " & - "NOREDUNDANT " & - "-gnatwR " & - "OBJECT_RENAMES " & - "-gnatw.r " & - "NOOBJECT_RENAMES " & - "-gnatw.R " & - "SUPPRESS " & - "-gnatws " & - "OVERRIDING_SIZE " & - "-gnatw.s " & - "NOOVERRIDING_SIZE " & - "-gnatw.S " & - "DELETED_CODE " & - "-gnatwt " & - "NODELETED_CODE " & - "-gnatwT " & - "SUSPICIOUS_CONTRACT " & - "-gnatw.t " & - "NOSUSPICIOUS_CONTRACT " & - "-gnatw.T " & - "UNINITIALIZED " & - "-Wuninitialized " & - "UNUSED " & - "-gnatwu " & - "NOUNUSED " & - "-gnatwU " & - "UNORDERED_ENUMERATIONS " & - "-gnatw.u " & - "NOUNORDERED_ENUMERATIONS " & - "-gnatw.U " & - "VARIABLES_UNINITIALIZED " & - "-gnatwv " & - "NOVARIABLES_UNINITIALIZED " & - "-gnatwV " & - "REVERSE_BIT_ORDER " & - "-gnatw.v " & - "NOREVERSE_BIT_ORDER " & - "-gnatw.V " & - "LOWBOUND_ASSUMED " & - "-gnatww " & - "NOLOWBOUND_ASSUMED " & - "-gnatwW " & - "WARNINGS_OFF_PRAGMAS " & - "-gnatw.w " & - "NO_WARNINGS_OFF_PRAGMAS " & - "-gnatw.W " & - "IMPORT_EXPORT_PRAGMAS " & - "-gnatwx " & - "NOIMPORT_EXPORT_PRAGMAS " & - "-gnatwX " & - "LOCAL_RAISE_HANDLING " & - "-gnatw.x " & - "NOLOCAL_RAISE_HANDLING " & - "-gnatw.X " & - "ADA_COMPATIBILITY " & - "-gnatwy " & - "NOADA_COMPATIBILITY " & - "-gnatwY " & - "WHY_SPEC_NEEDS_BODY " & - "-gnatw.y " & - "NO_WHY_SPEC_NEEDS_BODY " & - "-gnatw.Y " & - "UNCHECKED_CONVERSIONS " & - "-gnatwz " & - "NOUNCHECKED_CONVERSIONS " & - "-gnatwZ " & - "SIZE_ALIGNMENT " & - "-gnatw.z " & - "NOSIZE_ALIGNMENT " & - "-gnatw.Z"; - - -- /NOWARNINGS - -- - -- Suppress the output of all warning messages from the GNAT front end. - -- Note that it does not suppress warnings from the gcc back end. - -- - -- /WARNINGS[=(keyword[,...])] - -- - -- In addition to error messages, corresponding to illegalities as - -- defined in the reference manual, the compiler detects two kinds of - -- warning situations. First, the compiler considers some constructs - -- suspicious and generates a warning message to alert you to a possible - -- error. Second, if the compiler detects a situation that is sure to - -- raise an exception at runtime, it generates a warning message. - -- - -- You may specify the following keywords to change this behavior. - -- - -- DEFAULT (D) The default behavior. This includes the - -- following categories of warnings: - -- - -- ADA_COMPATIBILITY - -- ADDRESS_CLAUSE_OVERLAY - -- BIASED_REPRESENTATION - -- IMPORT_EXPORT_PRAGMAS - -- FAILING_ASSERTIONS - -- IMPLEMENTATION - -- LOWBOUND_ASSUMED - -- MISSING_PARENS - -- OVERLAPPING_ACTUALS - -- REVERSE_BIT_ORDER - -- SIZE_ALIGNMENT - -- SUSPICIOUS_CONTRACT - -- SUSPICIOUS_MODULUS - -- UNCHECKED_CONVERSIONS - -- UNRECOGNIZED_PRAGMA - -- VARIABLES_UNINITIALIZED - -- - -- as well as all warnings that cannot be - -- individually suppressed. - -- - -- ALL Activate all optional warnings. - -- Activates the most commong used optional - -- warning messages. The warnings that are not - -- turned on by this are: - -- - -- ADDRESS_CLAUSE_OVERLAY - -- ATOMIC_SYNCHRONIZATION - -- AVOID_GAPS - -- BAD_FIXED_VALUE - -- BIASED_ROUNDING - -- DELETED_CODE - -- ELABORATION - -- HIDING - -- IMPLICIT_DEREFERENCE - -- INHERITED_ASPECTS - -- OUT_PARAM_UNREF - -- OVERLAPPING_ACTUALS - -- OVERRIDING_SIZE - -- STANDARD_REDEFINITION - -- SUSPICIOUS_MODULUS - -- UNORDERED_ENUMERATION - -- WARNINGS_OFF_PRAGMAS - -- WHY_BODY_NEEDED - -- - -- All other optional warnings are turned on. - -- - -- OPTIONAL Turn on standard optional warnings. - -- This has the same effect as ALL. - -- - -- NOALL Suppress all optional errors. - -- Suppresses all optional warning messages - -- including those not activated by ALL. - -- - -- NOOPTIONAL Turn off standard optional warnings. - -- This has the same effect as NOALL - -- - -- EVERY Activate every optional warning. - -- Activates all optional warnings, including - -- those listed above as exceptions for ALL. - -- - -- ALL_GCC Request additional messages from the GCC - -- backend. Most of these are not Ada-relevant. - -- - -- UNINITIALIZED Activate warnings for uninitialized - -- variables. This is a GCC option, not an Ada - -- option. You must also specify the /OPTIMIZE - -- qualifier with a value other than NONE (in - -- other words, this option is effective only - -- if optimization is turned on). - -- - -- ERRORS Warning messages are to be treated as errors. - -- The warning string still appears, but the - -- warning messages are counted as errors, and - -- prevent the generation of an object file. - -- - -- SUPPRESS Completely suppress the output of all warning - -- messages. Same as /NOWARNINGS. - -- - -- NORMAL Sets normal warning mode, in which enabled - -- warnings are issued and treated as warnings - -- rather than errors. This is the default mode. - -- It can be used to cancel the effect of an - -- explicit /WARNINGS=SUPPRESS or - -- /WARNINGS=ERRORS. It also cancels the effect - -- of the implicit /WARNINGS=ERRORS that is - -- activated by the use of /STYLE=GNAT. - -- - -- TAG_WARNINGS Causes the string [xxx] to be added to - -- warnings that are controlled by the warning - -- switch -gnat??. See below for list of these - -- equivalent switch names. - -- - -- NOTAG_WARNINGS Turns off warning tag output (default - -- setting). - -- - -- The remaining entries control individual warning categories. If one - -- of these options is preceded by NO (e.g. NOAVOID_GAPS), then the - -- corresponding class of warnings is suppressed. The -gnatwxx tag - -- below the name indicates the non-VMS warning switch option. This is - -- used in the warning tags generated by TAG_WARNINGS (above) - -- - -- ADA_COMPATIBILITY Activate warnings for Ada compatibility issues. - -- (-gnatwy) This generates warnings for usages which are - -- legal, but may cause difficulties with later - -- Ada versions (e.g. the use of INTERFACE as an - -- identifier, which is legal in Ada 85, but in - -- Ada 2005, this is a reserved word). - -- - -- ATOMIC_SYNCHRONIZATION Activate info msgs for atomic synchronization. - -- (-gnatw.n) This generates information messages when an - -- access to an atomic variable requires the - -- generation of atomic synchronization code. - -- - -- AVOIDGAPS Activate warnings for gaps in records. - -- (-gnatw.h) This outputs a warning if a representation - -- clause for a record leaves unallocated bits. - -- - -- BAD_FIXED_VALUES Activate warnings on bad fixed values. - -- (-gnatwb) When this is enabled, a fixed-type literal - -- will generate a warning if its value does not - -- correspond to an exact value of the type and - -- is thus subject to rounding. - -- - -- BIASED_REPRESENTATION Activate warnings for biased representations. - -- (-gnatw.b) A warning will be generated if a size clause - -- or a component clause forces use of a biased - -- representation (e.g. range 1..5 with size 2). - -- - -- CONDITIONALS Activate warnings for conditional expressions - -- (-gnatwc) in tests where the expression is known to - -- be True or False at compile time. - -- - -- CONSTANT_VARIABLES Activate warnings on constant variables. - -- (-gnatwk) A warning is output for a variable which could - -- have been declared as a constant. - -- - -- DELETED_CODE Activate warning for conditional deleted code. - -- (-gnatwt) This option generates warnings for tracking of - -- code in conditionals (IF and CASE statements) - -- that is detected to be dead code which cannot - -- be executed, and which is removed by the - -- front end. This may be useful for detecting - -- deactivated code in certified applications. - -- - -- ELABORATION Activate warnings on missing pragma Elaborate - -- (-gnatwl) and Elaborate_All statements. - -- - -- FAILING_ASSERTIONS Activate warnings on failing assertions. - -- (-gnatw.a) Generates a warning for assertions that are - -- sure to fail. - -- - -- HIDING Activate warnings on hiding declarations. - -- (-gnatwh) A declaration is considered hiding if it is - -- for a non-overloadable entity, and declares - -- an entity with the same name as some other - -- entity that is directly or use-visible. - -- - -- IMPLEMENTATION Activate warnings for a with of an internal - -- (-gnatwi) GNAT implementation unit, defined as any unit - -- from the Ada, Interfaces, GNAT, DEC or System - -- hierarchies that is not documented in the - -- Ada Reference Manual or the GNAT Programmer's - -- Reference Manual. Such units are intended only - -- for internal implementation purposes and may - -- change from version to veresion, and should - -- not be with'ed by user programs. - -- - -- IMPLICIT_DEREFERENCE Activate warnings on implicit dereferencing. - -- (-gnatwd) The use of a prefix of an access type in an - -- indexed component, slice, or selected component - -- without an explicit .all will generate a - -- warning. When this warning is enabled, and no - -- warnings of this type are generated, access - -- checks occur only at points where the source - -- program contains an explicit use of .all. - -- - -- IMPORT_EXPORT_PRAGMAS Activate warnings on import-export pragmas. - -- (-gnatwx) This generates a warning on an Export or Import - -- pragma when the compiler detects a possible - -- conflict between the Ada and foreign language - -- calling sequences. For example, the use of - -- default parameters in a convention C procedure - -- is dubious because the C compiler cannot supply - -- the proper default, so a warning is issued. - -- - -- INEFFECTIVE_INLINE Activate warnings on ineffective Inlines. - -- (-gnatwp) Activates warnings for failure of front end - -- inlining (activated by /INLINE=FULL) to - -- inline a particular call when a pragma Inline - -- applies. There are many reasons for not - -- being able to inline a call, including most - -- commonly that the call is too complex to - -- inline. This warning can also be turned on - -- using /INLINE=FULL. - -- - -- INHERITED_ASPECTS Activate info messages for inherited aspects. - -- (-gantw.l) Outputs information messages for tagged types - -- that inherit aspects from a parent. - -- - -- LOCAL_RAISE_HANDLING Activate warnings for No_Exception_Propagation. - -- (-gnatw.x) This generates warnings for exception usage - -- when the No_Exception_Propagation restriction - -- is in effect. Warnings are given for implicit - -- or explicit exception raises which are not - -- covered by a local handler, and for exception - -- handlers which do not cover a local raise. - -- - -- LOWBOUND_ASSUMED Activate warnings for low bound assumptions. - -- (-gnatww) Outputs warnings if code appears to depend on - -- an assumption about the lower bound of one of - -- the subprogram parameters (for example using - -- S(1 .. 5) instead of S(S'First .. S'First + 4). - -- - -- MISSING_COMPONENT_CLAUSES - -- (-gnatw.c) Activate warnings for unrepped component. - -- Generates a warning for a record component - -- which does not have a component clause if - -- at least one component claused is present - -- for some other component of the record. - -- - -- MISSING_PARENS Activate warnings for missing parentheses. - -- (-gnatwq) Outputs a warning for cases where parentheses - -- are not used and the result is potential - -- ambiguity from a reader's point of view. - -- For example (not a > b) when a and b are - -- modular means (not (a) > b) and very likely - -- the programmer intended (not (a > b)). - -- - -- MODIFIED_UNREF Activate warning for assigned but not read. - -- (-gnatwm) Outputs a warning for variables that are - -- assigned (using an initialization value or an - -- assignment statements) but whose value is - -- never read. The warning is suppressed for - -- volatile variables and also for variables - -- that are renamings of other variables or for - -- which an address clause is given. - -- - -- OBJECT_RENAME Activate warnings for non limited objects - -- (-gnatw.r) renaming parameterless functions. - -- - -- OBSOLESCENT Activates warnings for calls to subprograms - -- (-gnatwj) marked with pragma Obsolescent and for use of - -- features in Annex J of the Ada Reference - -- Manual. In the case of Annex J, not all - -- features are flagged. In particular use of - -- the renamed packages (like Text_IO), use of - -- package ASCII, and use of the attribute - -- 'Constrained are not flagged, since these are - -- common and would generate many annoying - -- false-positive warnings. - -- - -- OUT_PARAM_UNREF Activate warnings on unreferenced OUT params. - -- (-gantw.o) This switch activates warnings for variables - -- that are modified by using them as actuals for - -- a call to a procedure with an out mode formal, - -- where the resulting assigned value is never - -- read. It is applicable in the case where there - -- is more than one out mode formal. If there is - -- only one out mode formal, the warning is issued - -- by default (controlled by UNUSED). The warning - -- is suppressed for volatile variables and also - -- for variables that are renamings of other - -- variables or for which an address clause - -- is given. - -- - -- OVERLAPPING_ACTUALS Activate warnings on overlapping actuals. - -- (-gnatw.i) Enables a warning on statically detectable - -- overlapping actuals in a subprogram call, - -- when one of the actuals is an in-out - -- parameter, and the types of the actuals - -- are not by-copy types. - -- - -- OVERLAYS Activate warnings for possibly unintended - -- (-gnatwo) initialization effects of defining address - -- clauses that cause one variable to overlap - -- another. - -- - -- OVERRIDING_SIZE Activate warning on overridden size clause. - -- (-gnatw.s) Generates a warning if an explicit size clause - -- is overridden by a component clause in a record - -- or a component size in an array. - -- - -- PARAMETER_ORDER Activate warnings for suspicious parameter - -- (-gnatw.p) ordering. A warning is generated if positional - -- ordering is used and the actuals match the - -- formal names, but are in the wrong order (e.g. - -- GEN (B, A), when the formals of GEN are A, B.) - -- No warning is generated for named parameters, - -- so GEN (A => B, B => A) would be allowed. - -- - -- REDUNDANT Activate warnings for redundant constructs. - -- (-gnatwr) In particular assignments of a variable to - -- itself, and a type conversion that converts - -- an object to its own type. - -- - -- REVERSE_BIT_ORDER Activates info messages for reverse bit order. - -- (-gnatw.v) Generates information messages that show the - -- effect of specifying reverse bit order for - -- a record on individual components. - -- - -- SIZE_ALIGNMENT Activates warnings for record types for which - -- (-gnatw.z) explicit size and alignment values are given, - -- where the size value is not a multiple of the - -- alignment value, resulting in an object size - -- larger than the specified size. - -- - -- STANDARD_REDEFINITION Activate warnings on standard redefinition. - -- (-gnatw.k) Generates a warning message if a declaration - -- declares an identifier that matches one that - -- is declared in package Standard (e.g. Float). - -- - -- SUSPICIOUS_CONTRACT Activate warnings on suspicious postconditions. - -- (-gnatw.t) This generates warnings if a postcondition for - -- a function does not mention the result, or if - -- a postcondition for a procedure depends only on - -- the entry values of the parameters. - -- - -- SUSPICIOUS_MODULUS Warn on suspicious modulus values, for - -- (-gnatw.m) example "mod 7" is suspicious for a size with - -- 7 bits, since it was likely intended to be - -- "mod 2**7". Similarly "mod 32" is considered - -- suspicious, since it was likely intended to - -- be "mod 2**32". - -- - -- UNCHECKED_CONVERSIONS Activates warnings on unchecked conversions. - -- (-gnatwz) Causes warnings to be generated for unchecked - -- conversions between types that are known at - -- compile time to have different sizes. - -- - -- UNORDERED_ENUMERATION Activate warnings for unordered enumeration. - -- (-gnatw.u) Causes warnings to be generated if for an - -- enumeration type that does not have a pragma - -- Ordered that applies, if a subtype with a - -- range is used, or a comparison other than - -- [in]equality appears for values of the type. - -- - -- UNRECOGNIZED_PRAGMAS Activate warnings for unrecognized pragmas. - -- (-gnatwg) Such pragmas are ignored other than generating - -- these warnings. - -- - -- UNREFERENCED_FORMALS Activate warnings on unreferenced formals. - -- (-gnatwf) Causes a warning to be generated if a formal - -- parameter is not referenced in the body of - -- the subprogram. Note that the combination - -- UNUSED followed by NOUNREFERENCED_FORMALS - -- has the effect of warning on unreferenced - -- entities other than subprogram formals. - -- - -- UNUSED Activates warnings to be generated for entities - -- (-gantwu) that are defined but not referenced, and for - -- units that are with'ed and not referenced. In - -- the case of packages, a warning is also - -- generated if no entities in the package are - -- referenced. This means that if the package - -- is referenced but the only references are in - -- in use clauses or renames declarations, a - -- warning is still generated. A warning is also - -- generated for a generic package that is - -- with'ed but never instantiated. In the case - -- where a package or subprogram body is - -- compiled, and there is a with on the - -- corresponding spec that is only referenced - -- in the body, a warning is also generated, - -- noting the with can be moved to the body. - -- - -- VARIABLES_UNINITIALIZED Activates warnings on unassigned variables. - -- (-gnatwv) Causes warnings to be generated when a - -- variable is accessed which may not be - -- properly initialized. - -- - -- WARNINGS_OFF_PRAGMAS Activates warnings for pragma Warnings (Off). - -- (-gnatw.w) This generates a warning if the specific string - -- version the pragma is used as a local pragma - -- (i.e. not a configuration pragma) and no - -- warning is suppressed as a result. - -- - -- WHY_SPEC_NEEDS_BODY Generates information messages showing why a - -- (-gnatw.y) package specification requires a body. - -- - S_GCC_WarnX : aliased constant S := "/NOWARNINGS " & - "-gnatws"; - -- NODOC (see /WARNINGS) - - S_GCC_No_Back : aliased constant S := "/NO_BACK_END_WARNINGS " & - "-w"; - -- /NO_BACK_END_WARNINGS - -- - -- Inhibit all warning messages of the GCC back-end. - - S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" & - "BRACKETS " & - "-gnatWb " & - "HEX " & - "-gnatWh " & - "UPPER " & - "-gnatWu " & - "SHIFT_JIS " & - "-gnatWs " & - "UTF8 " & - "-gnatW8 " & - "EUC " & - "-gnatWe"; - -- /NOWIDE_CHARACTER_ENCODING (D) - -- /WIDE_CHARACTER_ENCODING[=encode-type] - -- - -- Specifies the mechanism used to encode wide characters. 'encode-type' - -- is one of the following: - -- - -- BRACKETS (D) A wide character is encoded as ["xxxx"] where XXXX - -- are four hexadecimal digits representing the coding - -- ('Pos value) of the character in type - -- Wide_Character. The hexadecimal digits may use upper - -- or lower case letters. - -- - -- This notation can also be used for upper half - -- Character values using the format ["xx"] where XX is - -- two hexadecimal digits representing the coding ('Pos - -- value) of the character in type Character (or - -- Wide_Character). The hexadecimal digits may use upper - -- of lower case. - -- - -- NONE No wide characters are allowed. Same - -- as /NOWIDE_CHARACTER_ENCODING. - -- - -- HEX In this encoding, a wide character is represented by - -- the following five character sequence: ESC a b c d - -- Where 'a', 'b', 'c', and '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 16#A345#. This - -- scheme is compatible with use of the full - -- Wide_Character set. - -- - -- UPPER The wide character with encoding 16#abcd# where the - -- upper bit is on (in other words, "a" is in the range - -- 8-F) is represented as two bytes, 16#ab# and 16#cd#. - -- The second byte may never be a format control - -- character, but is not required to be in the upper - -- half. This method can be also used for shift-JIS or - -- EUC, where the internal coding matches the external - -- coding. - -- - -- SHIFT_JIS A wide character is represented by a two-character - -- sequence, 16#ab# and 16#cd#, with the restrictions - -- described for upper-half encoding as described above. - -- The internal character code is the corresponding JIS - -- character according to the standard algorithm for - -- Shift-JIS conversion. Only characters defined in the - -- JIS code set table can be used with this encoding - -- method. - -- - -- UTF8 A wide character is represented using - -- UCS Transformation Format 8 (UTF-8) as defined in Annex - -- R of ISO 10646-1/Am.2. Depending on the character - -- value, the representation is a one, two, or three byte - -- sequence: - -- - -- 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 16-bit character value. Note that all lower - -- half ASCII characters are represented as ASCII bytes - -- and all upper half characters and other wide characters - -- are represented as sequences of upper-half (The full - -- UTF-8 scheme allows for encoding 31-bit characters as - -- 6-byte sequences, but in this implementation, all UTF-8 - -- sequences of four or more bytes length will be treated - -- as illegal). - -- - -- EUC A wide character is represented by a two-character - -- sequence 16#ab# and 16#cd#, with both characters being - -- in the upper half. The internal character code is the - -- corresponding JIS character according to the EUC - -- encoding algorithm. Only characters defined in the JIS - -- code set table can be used with this encoding method. - - S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " & - "-gnatWn"; - -- NODOC (see /WIDE_CHARACTER_ENCODING) - - S_GCC_Xdebug : aliased constant S := "/XDEBUG " & - "-gnatD"; - -- /NOXDEBUG (D) - -- /XDEBUG - -- - -- Output expanded source files for source level debugging. - -- The expanded source (see /EXPAND_SOURCE) is written to files - -- with names formed by appending "_DG" to the input file name, - -- The debugging information generated by the /DEBUG qualifier will then - -- refer to the generated file. This allows 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. The maximum line length for the output is 72. - - S_GCC_Lxdebug : aliased constant S := "/LXDEBUG=#" & - "-gnatD=#"; - -- /LXDEBUG=nnn - -- - -- Output expanded source files for source level debugging. - -- The expanded source (see /EXPAND_SOURCE) is written to files - -- with names formed by appending "_DG" to the input file name, - -- The debugging information generated by the /DEBUG qualifier will then - -- refer to the generated file. This allows 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. The parameter is the maximum line length for - -- the output. - - S_GCC_Xref : aliased constant S := "/XREF=" & - "GENERATE " & - "!-gnatx " & - "SUPPRESS " & - "-gnatx"; - -- /XREF[=keyword] - -- - -- Normally the compiler generates full cross-referencing information in - -- the .ALI file. This information is used by a number of tools, - -- including GNAT FIND and GNAT XREF. - -- - -- GENERATE (D) Generate cross-referencing information. - -- - -- SUPPRESS Suppress cross-referencing information. - -- This saves some space and may slightly - -- speed up compilation, but means that some - -- tools cannot be used. - - GCC_Switches : aliased constant Switches := - (S_GCC_Ada_83 'Access, - S_GCC_Ada_95 'Access, - S_GCC_Ada_05 'Access, - S_GCC_Ada_2005'Access, - S_GCC_Ada_12 'Access, - S_GCC_Ada_2012'Access, - S_GCC_Add 'Access, - S_GCC_AlCheck 'Access, - S_GCC_Asm 'Access, - S_GCC_AValid 'Access, - S_GCC_CategW 'Access, - S_GCC_Checks 'Access, - S_GCC_Chflov 'Access, - S_GCC_ChecksX 'Access, - S_GCC_Compres 'Access, - S_GCC_Config 'Access, - S_GCC_Current 'Access, - S_GCC_Debug 'Access, - S_GCC_DebugX 'Access, - S_GCC_Data 'Access, - S_GCC_DisAtom 'Access, - S_GCC_Dist 'Access, - S_GCC_DistX 'Access, - S_GCC_ElabI 'Access, - S_GCC_Error 'Access, - S_GCC_ErrorX 'Access, - S_GCC_Expand 'Access, - S_GCC_Lexpand 'Access, - S_GCC_Except 'Access, - S_GCC_Extend 'Access, - S_GCC_Ext 'Access, - S_GCC_File 'Access, - S_GCC_Follow 'Access, - S_GCC_Force 'Access, - S_GCC_Full 'Access, - S_GCC_Generate'Access, - S_GCC_GNAT 'Access, - S_GCC_Help 'Access, - S_GCC_Ident 'Access, - S_GCC_IdentX 'Access, - S_GCC_IgnoreR 'Access, - S_GCC_IgnoreS 'Access, - S_GCC_IgnoreU 'Access, - S_GCC_Immed 'Access, - S_GCC_Inline 'Access, - S_GCC_InlineX 'Access, - S_GCC_Intsrc 'Access, - S_GCC_Just 'Access, - S_GCC_JustX 'Access, - S_GCC_Length 'Access, - S_GCC_List 'Access, - S_GCC_Output 'Access, - S_GCC_Machine 'Access, - S_GCC_Mapping 'Access, - S_GCC_MaxI 'Access, - S_GCC_Multi 'Access, - S_GCC_Mess 'Access, - S_GCC_Nesting 'Access, - S_GCC_Noadc 'Access, - S_GCC_NoElabI 'Access, - S_GCC_Noload 'Access, - S_GCC_Nostinc 'Access, - S_GCC_Nostlib 'Access, - S_GCC_NoWarnP 'Access, - S_GCC_Opt 'Access, - S_GCC_OptX 'Access, - S_GCC_Overflo 'Access, - S_GCC_PValid 'Access, - S_GCC_Pointer 'Access, - S_GCC_Polling 'Access, - S_GCC_Project 'Access, - S_GCC_Psta 'Access, - S_GCC_Report 'Access, - S_GCC_ReportX 'Access, - S_GCC_Repinfo 'Access, - S_GCC_RepinfX 'Access, - S_GCC_RTS 'Access, - S_GCC_SCO 'Access, - S_GCC_Search 'Access, - S_GCC_Src_Info'Access, - S_GCC_Style 'Access, - S_GCC_StyleX 'Access, - S_GCC_Subdirs 'Access, - S_GCC_Symbol 'Access, - S_GCC_Syntax 'Access, - S_GCC_Table 'Access, - S_GCC_Target_W'Access, - S_GCC_Target_R'Access, - S_GCC_Trace 'Access, - S_GCC_Tree 'Access, - S_GCC_Trys 'Access, - S_GCC_USL 'Access, - S_GCC_Units 'Access, - S_GCC_Unique 'Access, - S_GCC_Upcase 'Access, - S_GCC_Valid 'Access, - S_GCC_Verbose 'Access, - S_GCC_Verb_Asm'Access, - S_GCC_Warn 'Access, - S_GCC_WarnX 'Access, - S_GCC_Wide 'Access, - S_GCC_WideX 'Access, - S_GCC_No_Back 'Access, - S_GCC_Xdebug 'Access, - S_GCC_Lxdebug 'Access, - S_GCC_Xref 'Access); - - ---------------------------- - -- Switches for GNAT ELIM -- - ---------------------------- - - S_Elim_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Elim_All : aliased constant S := "/ALL " & - "-a"; - -- /NOALL (D) - -- /ALL - -- - -- Also look for subprograms from the GNAT run time that can be - -- eliminated. Note that when 'gnat.adc' is produced using this switch, - -- the entire program must be recompiled with qualifier /ALL_FILES of - -- GNAT MAKE. - - S_Elim_Bind : aliased constant S := "/BIND_FILE=<" & - "-b>"; - -- /BIND_FILE=file_name - -- - -- Specifies file_name as the bind file to process. If this qualifier is - -- not used, the name of the bind file is computed from the full expanded - -- Ada name of a main subprogram. - - S_Elim_Comp : aliased constant S := "/COMPILER=@" & - "--GCC=@"; - -- /COMPILER=path_name - -- - -- Instructs GNAT ELIM to use a specific gcc compiler instead of one - -- available on the path. - - S_Elim_Config : aliased constant S := "/CONFIGURATION_PRAGMAS=<" & - "-C>"; - -- /CONFIGURATION_PRAGMAS=path_name - -- - -- Specifies a file that contains configuration pragmas. - -- The file must be specified with absolute path. - - S_Elim_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- /NOCURRENT_DIRECTORY - -- - -- Look for source files in the default directory. - - S_Elim_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Elim_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Elim_GNATMAKE : aliased constant S := "/GNATMAKE=@" & - "--GNATMAKE=@"; - -- /GNATMAKE=path_name - -- - -- Instructs GNAT MAKE to use a specific gnatmake instead of one available - -- on the path. - - S_Elim_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Elim_Nodisp : aliased constant S := "/NO_DISPATCH " & - "--no-elim-dispatch"; - -- /NONO_DISPATCH (D) - -- /NO_DISPATCH - -- - -- Do not generate pragmas for dispatching operations. - - S_Elim_Ignore : aliased constant S := "/IGNORE=@" & - "--ignore=@"; - -- /IGNORE=filename - -- - -- Do not generate pragmas for subprograms declared in the sources - -- listed in a specified file - - S_Elim_Processes : aliased constant S := "/PROCESSES=#" & - "-j#"; - - -- /NOPROCESSES (D) - -- /PROCESSES=NNN - -- - -- Use NNN processes to carry out the tree creations (internal - -- representations of the argument sources). On a multiprocessor machine - -- this speeds up processing of big sets of argument sources. If NNN is 0, - -- then the maximum number of parallel tree creations is the number of - -- core processors on the platform. - - S_Elim_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- gnatelim. The source directories to be searched will be communicated - -- to gnatelim through logical name ADA_PRJ_INCLUDE_FILE. - - S_Elim_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Quiet mode: by default GNAT ELIM outputs to the standard error stream - -- the number of program units left to be processed. This option turns - -- this trace off. - - S_Elim_Files : aliased constant S := "/FILES=@" & - "-files=@"; - - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Elim_Log : aliased constant S := "/LOG " & - "-log"; - -- /NOLOG (D) - -- /LOG - -- - -- Duplicate all the output sent to Stderr into a default log file. - - S_Elim_Logfile : aliased constant S := "/LOGFILE=@" & - "-log@"; - - -- /LOGFILE=logfilename - -- - -- Duplicate all the output sent to Stderr into a specified log file. - - S_Elim_Main : aliased constant S := "/MAIN=@" & - "-main=@"; - - -- /MAIN=filename - -- - -- Specify the main subprogram of the partition to analyse. - - S_Elim_Out : aliased constant S := "/OUTPUT=@" & - "-o@"; - -- /OUTPUT=filename - -- - -- Specify the name of the output file. - - S_Elim_Time : aliased constant S := "/TIME " & - "-t"; - -- /NOTIME (D) - -- /TIME - -- - -- Print out execution time - - S_Elim_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory, ...) - -- - -- When looking for source files also look in the specified directories. - - S_Elim_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Elim_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Verbose mode: GNAT ELIM version information is output as Ada comments - -- to the standard output stream. Also, in addition to the number of - -- program units left, GNAT ELIM will output the name of the current unit - -- being processed. - - S_Elim_Warn : aliased constant S := "/WARNINGS=" & - "NORMAL " & - "-wn " & - "QUIET " & - "-ws"; - - -- /WARNINGS[=(keyword[,...])] - -- - -- The following keywords are supported: - -- - -- NORMAL (D) Print warning all the messages. - -- QUIET Some warning messages are suppressed - - Elim_Switches : aliased constant Switches := - (S_Elim_Add 'Access, - S_Elim_All 'Access, - S_Elim_Bind 'Access, - S_Elim_Comp 'Access, - S_Elim_Config 'Access, - S_Elim_Current 'Access, - S_Elim_Ext 'Access, - S_Elim_Files 'Access, - S_Elim_Follow 'Access, - S_Elim_GNATMAKE 'Access, - S_Elim_Log 'Access, - S_Elim_Logfile 'Access, - S_Elim_Main 'Access, - S_Elim_Mess 'Access, - S_Elim_Nodisp 'Access, - S_Elim_Out 'Access, - S_Elim_Processes'Access, - S_Elim_Project 'Access, - S_Elim_Quiet 'Access, - S_Elim_Search 'Access, - S_Elim_Subdirs 'Access, - S_Elim_Time 'Access, - S_Elim_Verb 'Access, - S_Elim_Warn 'Access); - - ---------------------------- - -- Switches for GNAT FIND -- - ---------------------------- - - S_Find_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Find_All : aliased constant S := "/ALL_FILES " & - "-a"; - -- /NOALL_FILES (D) - -- /ALL_FILES - -- - -- If this switch is present, FIND and XREF will parse the read-only - -- files found in the library search path. Otherwise, these files will - -- be ignored. This option can be used to protect Gnat sources or your - -- own libraries from being parsed, thus making FIND and XREF much - -- faster, and their output much smaller. - - S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " & - "-d"; - -- /NODERIVED_TYPE_INFORMATION (D) - -- /DERIVED_TYPE_INFORMATION - -- - -- Output the parent type reference for each matching derived types. - - S_Find_Expr : aliased constant S := "/EXPRESSIONS " & - "-e"; - -- /NOEXPRESSIONS (D) - -- /EXPRESSIONS - -- - -- By default, FIND accepts the simple regular expression set for pattern. - -- If this switch is set, then the pattern will be considered as a full - -- Unix-style regular expression. - - S_Find_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Find_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Find_Full : aliased constant S := "/FULL_PATHNAME " & - "-f"; - -- /NOFULL_PATHNAME (D) - -- /FULL_PATHNAME - -- - -- If this switch is set, the output file names will be preceded by their - -- directory (if the file was found in the search path). If this switch - -- is not set, the directory will not be printed. - - S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " & - "-g"; - -- /NOIGNORE_LOCALS (D) - -- /IGNORE_LOCALS - -- - -- If this switch is set, information is output only for library-level - -- entities, ignoring local entities. The use of this switch may - -- accelerate FIND and XREF. - - S_Find_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; - -- /NOSTD_INCLUDES - -- - -- Do not look for sources in the system default directory. - - S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & - "-nostdlib"; - -- /NOSTD_LIBRARIES - -- - -- Do not look for library files in the system default directory. - - S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" & - "-aO*"; - -- /OBJECT_SEARCH=(directory,...) - -- - -- When searching for library and object files, look in the specified - -- directories. The order in which library files are searched is the same - -- as for MAKE. - - S_Find_Print : aliased constant S := "/PRINT_LINES " & - "-s"; - -- /NOPRINT_LINES (D) - -- /PRINT_LINES - -- - -- Output the content of the Ada source file lines were the entity was - -- found. - - S_Find_Project : aliased constant S := "/PROJECT=@" & - "-p@"; - -- /PROJECT=file - -- - -- Specify a project file to use. By default, FIND and XREF will try to - -- locate a project file in the current directory. - -- - -- If a project file is either specified or found by the tools, then the - -- content of the source directory and object directory lines are added - -- as if they had been specified respectively by /SOURCE_SEARCH and - -- /OBJECT_SEARCH. - -- - -- This qualifier is not compatible with /PROJECT_FILE - - S_Find_Prj : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before looking for sources. - -- The source and object directories to be searched will be communicated - -- to gnatfind through logical names ADA_PRJ_INCLUDE_FILE and - -- ADA_PRJ_OBJECTS_FILE. - - S_Find_Ref : aliased constant S := "/REFERENCES " & - "-r"; - -- /NOREFERENCES (D) - -- /REFERENCES - -- - -- By default, FIND will output only the information about the - -- declaration, body or type completion of the entities. If this switch - -- is set, the FIND will locate every reference to the entities in the - -- files specified on the command line (or in every file in the search - -- path if no file is given on the command line). - - S_Find_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory,...) - -- - -- Equivalent to: - -- /OBJECT_SEARCH=(directory,...) /SOURCE_SEARCH=(directory,...) - - S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" & - "-aI*"; - -- /SOURCE_SEARCH=(directory,...) - -- - -- When looking for source files also look in the specified directories. - -- The order in which source file search is undertaken is the same as for - -- MAKE. - - S_Find_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " & - "-t"; - -- /NOTYPE_HIERARCHY (D) - -- /TYPE_HIERARCHY - -- - -- Output the type hierarchy for the specified type. It acts like the - -- /DERIVED_TYPE_INFORMATION qualifier, but recursively from parent type - -- to parent type. When this qualifier is specified it is not possible to - -- specify more than one file. - - Find_Switches : aliased constant Switches := - (S_Find_Add 'Access, - S_Find_All 'Access, - S_Find_Deriv 'Access, - S_Find_Expr 'Access, - S_Find_Ext 'Access, - S_Find_Follow 'Access, - S_Find_Full 'Access, - S_Find_Ignore 'Access, - S_Find_Mess 'Access, - S_Find_Nostinc 'Access, - S_Find_Nostlib 'Access, - S_Find_Object 'Access, - S_Find_Print 'Access, - S_Find_Project 'Access, - S_Find_Prj 'Access, - S_Find_Ref 'Access, - S_Find_Search 'Access, - S_Find_Source 'Access, - S_Find_Subdirs 'Access, - S_Find_Types 'Access); - - ------------------------------ - -- Switches for GNAT KRUNCH -- - ------------------------------ - - S_Krunch_Count : aliased constant S := "/COUNT=#" & - "`#"; - -- /COUNT=39 (D) - -- /COUNT=nnn - -- - -- Limit file names to nnn characters (where nnn is a decimal - -- integer). The maximum file name length is 39, but if you want to - -- generate a set of files that would be usable if ported to a system - -- with some different maximum file length, then a different value can - -- be specified. - - Krunch_Switches : aliased constant Switches := - (1 .. 1 => S_Krunch_Count 'Access); - - ---------------------------- - -- Switches for GNAT LINK -- - ---------------------------- - - S_Link_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Link_Bind : aliased constant S := "/BIND_FILE=" & - "ADA " & - "-A " & - "C " & - "-C"; - -- /BIND_FILE=[bind-file-option] - -- - -- Specifies the language of the binder generated file. - -- - -- ADA (D) Binder file is Ada. - -- - -- C Binder file is 'C'. - - S_Link_Debug : aliased constant S := "/DEBUG=" & - "ALL " & - "-g3 " & - "NONE " & - "-g0 " & - "TRACEBACK " & - "-g1 " & - "NOTRACEBACK " & - "-g0"; - -- /NODEBUG (D) - -- /DEBUG[=debug-option] - -- - -- Specifies the amount of debugging information included. 'debug-option' - -- is one of the following: - -- - -- ALL (D) Include full debugging information. - -- - -- NONE Provide no debugging information. Same as /NODEBUG. - -- - -- TRACEBACK Provide sufficient debug information for a traceback. - -- - -- NOTRACEBACK Same as NONE. - - S_Link_Nodebug : aliased constant S := "/NODEBUG " & - "-g0"; - -- NODOC (see /DEBUG) - - S_Link_Execut : aliased constant S := "/EXECUTABLE=@" & - "-o@"; - -- /EXECUTABLE=exec-name - -- - -- 'exec-name' specifies an alternative name for the generated executable - -- program. If this qualifier switch is omitted, the executable is called - -- the name of the main unit. So "$ GNAT LINK TRY.ALI" creates an - -- executable called TRY.EXE. - - S_Link_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Link_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Link_Forlink : aliased constant S := "/FOR_LINKER=" & '"' & - "--for-linker=" & '"'; - -- /FOR_LINKER= - -- - -- Transmit the option to the underlying linker. - - S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " & - "-f"; - -- /NOFORCE_OBJECT_FILE_LIST (D) - -- /FORCE_OBJECT_FILE_LIST - -- - -- Forces the generation of a file that contains commands for the linker. - -- This is useful in some cases to deal with special situations where the - -- command line length is exceeded. - - S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & - "--for-linker=IDENT=" & - '"'; - -- /IDENTIFICATION="" - -- - -- "" specifies the string to be stored in the image file ident- - -- ification field in the image header. It overrides any pragma Ident - -- specified string. - - S_Link_NoInhib : aliased constant S := "/NOINHIBIT-EXEC " & - "--for-linker=--noinhibit-exec"; - -- /NOINHIBIT-EXEC (D) - -- - -- Preserve executable if there are warnings. This is the default. - - S_Link_Inhib : aliased constant S := "/INHIBIT-EXEC " & - "--for-linker=--inhibit-exec"; - -- /INHIBIT-EXEC - -- - -- Remove executable if there are warnings. - - S_Link_Libdir : aliased constant S := "/LIBDIR=*" & - "-L*"; - -- /LIBDIR=(directory, ...) - -- - -- Look for libraries in the specified directories. - - S_Link_Library : aliased constant S := "/LIBRARY=|" & - "-l|"; - -- /LIBRARY=xyz - -- - -- Link with library named "xyz". - - S_Link_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Link_Nocomp : aliased constant S := "/NOCOMPILE " & - "-n"; - -- /NOCOMPILE - -- - -- Do not compile the file generated by the binder. - -- This may be used when a link is rerun with different options, - -- but there is no need to recompile the binder generated file. - - S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " & - "-nostartfiles"; - -- /NOSTART_FILES - -- - -- Link in default image initialization and startup functions. - - S_Link_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- linker. - -- The source and object directories to be searched will be communicated - -- to the linker through logical names ADA_PRJ_INCLUDE_FILE and - -- ADA_PRJ_OBJECTS_FILE. - - S_Link_Return : aliased constant S := "/RETURN_CODES=" & - "POSIX " & - "!-mvms-return-codes " & - "VMS " & - "-mvms-return-codes"; - -- /RETURN_CODES=POSIX (D) - -- /RETURN_CODES=VMS - -- - -- Specifies the style of codes returned by - -- Ada.Command_Line.Set_Exit_Status. Must be used in conjunction with - -- and match the Bind qualifier with the same name. - -- - -- POSIX (D) Return Posix compatible exit codes. - -- - -- VMS Return VMS compatible exit codes. The value returned - -- is identically equal to the Set_Exit_Status parameter. - - S_Link_Static : aliased constant S := "/STATIC " & - "--for-linker=-static"; - -- /NOSTATIC (D) - -- /STATIC - -- - -- Indicate to the linker that the link is static. - - S_Link_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Link_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Causes additional information to be output, including a full list of - -- the included object files. This switch option is most useful when you - -- want to see what set of object files are being used in the link step. - - S_Link_ZZZZZ : aliased constant S := "/ " & - "--for-linker="; - -- / - -- - -- Any other switch that will be transmitted to the underlying linker. - - Link_Switches : aliased constant Switches := - (S_Link_Add 'Access, - S_Link_Bind 'Access, - S_Link_Debug 'Access, - S_Link_Nodebug 'Access, - S_Link_Execut 'Access, - S_Link_Ext 'Access, - S_Link_Follow 'Access, - S_Link_Forlink 'Access, - S_Link_Force 'Access, - S_Link_Ident 'Access, - S_Link_NoInhib 'Access, - S_Link_Inhib 'Access, - S_Link_Libdir 'Access, - S_Link_Library 'Access, - S_Link_Mess 'Access, - S_Link_Nocomp 'Access, - S_Link_Nofiles 'Access, - S_Link_Project 'Access, - S_Link_Return 'Access, - S_Link_Static 'Access, - S_Link_Subdirs 'Access, - S_Link_Verb 'Access, - S_Link_ZZZZZ 'Access); - - ---------------------------- - -- Switches for GNAT LIST -- - ---------------------------- - - S_List_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_List_All : aliased constant S := "/ALL_UNITS " & - "-a"; - -- /NOALL_UNITS (D) - -- /ALL_UNITS - -- - -- Consider all units, including those of the predefined Ada library. - -- Especially useful with /DEPENDENCIES. - - S_List_Allproj : aliased constant S := "/ALL_PROJECTS " & - "-U"; - -- /NOALL_PROJECTS (D) - -- /ALL_PROJECTS - -- - -- When used with a project file and no file specified, indicate - -- that gnatls should be called for all sources of all projects in - -- the project tree. - - S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- /NOCURRENT_DIRECTORY - -- - -- Look for source, library or object files in the default directory. - - S_List_Depend : aliased constant S := "/DEPENDENCIES " & - "-d"; - -- /NODEPENDENCIES (D) - -- /DEPENDENCIES - - S_List_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_List_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_List_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_List_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; - -- /NOSTD_INCLUDES - -- - -- Do not look for sources of the run time in the standard directory. - - S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" & - "-aO*"; - -- /OBJECT_SEARCH=(directory,...) - -- - -- When looking for library and object files look also in the specified - -- directories. - - S_List_Output : aliased constant S := "/OUTPUT=" & - "SOURCES " & - "-s " & - "DEPEND " & - "-d " & - "OBJECTS " & - "-o " & - "UNITS " & - "-u " & - "OPTIONS " & - "-h " & - "VERBOSE " & - "-v "; - -- /OUTPUT=(option,option,...) - -- - -- SOURCES (D) Only output information about source files. - -- - -- DEPEND List sources from which specified units depend on. - -- - -- OBJECTS Only output information about object files. - -- - -- UNITS Only output information about compilation units. - -- - -- OPTIONS Output the list of options. - -- - -- VERBOSE Output the complete source and object paths. - -- Do not use the default column layout but instead - -- use long format giving as much as information - -- possible on each requested units, including - -- special characteristics. - - S_List_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before doing any listing. - -- The source and object directories to be searched will be communicated - -- to gnatlist through logical names ADA_PRJ_INCLUDE_FILE and - -- ADA_PRJ_OBJECTS_FILE. - - S_List_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory,...) - -- - -- Search the specified directories for both source and object files. - - S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" & - "-aI*"; - -- /SOURCE_SEARCH=(directory,...) - -- - -- When looking for source files also look in the specified directories. - - S_List_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - List_Switches : aliased constant Switches := - (S_List_Add 'Access, - S_List_All 'Access, - S_List_Allproj 'Access, - S_List_Current 'Access, - S_List_Depend 'Access, - S_List_Ext 'Access, - S_List_Files 'Access, - S_List_Follow 'Access, - S_List_Mess 'Access, - S_List_Nostinc 'Access, - S_List_Object 'Access, - S_List_Output 'Access, - S_List_Project 'Access, - S_List_Search 'Access, - S_List_Source 'Access, - S_List_Subdirs 'Access); - - ---------------------------- - -- Switches for GNAT MAKE -- - ---------------------------- - - S_Make_Actions : aliased constant S := "/ACTIONS=" & - "COMPILE " & - "-c " & - "BIND " & - "-b " & - "LINK " & - "-l "; - -- /ACTIONS=(keyword[,...]) - -- - -- GNAT MAKE default behavior is to check if the sources are up to date, - -- compile those sources that are not up to date, bind the main source, - -- then link the executable. - -- - -- With the /ACTIONS qualifier, GNAT MAKE may be restricted to one or - -- two of these three steps: - -- - -- o Compile - -- o Bind - -- o Link - -- - -- - -- You may specify one or more of the following keywords to the /ACTIONS - -- qualifier: - -- - -- BIND Bind only. Can be combined with /ACTIONS=COMPILE - -- to do compilation and binding, but no linking. - -- Can be combined with /ACTIONS=LINK to do binding and - -- linking. When not combined with /ACTIONS=COMPILE, - -- all the units in the closure of the main program must - -- have been previously compiled and must be up to date. - -- - -- COMPILE Compile only. Do not perform binding, except when - -- /ACTIONS=BIND is also specified. Do not perform - -- linking, except if both /ACTIONS=BIND and /ACTIONS=LINK - -- are also specified. - -- - -- LINK Link only. Can be combined with /ACTIONS=BIND to do - -- binding and linking. Linking will not be performed - -- if combined with /ACTIONS=COMPILE but not with - -- /ACTIONS=BIND\. When not combined with /ACTIONS=BIND - -- all the units in the closure of the main program must - -- have been previously compiled and must be up to date, - -- and the main program need to have been bound. - - S_Make_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Make_All : aliased constant S := "/ALL_FILES " & - "-a"; - -- /NOALL_FILES (D) - -- /ALL_FILES - -- - -- Consider all files in the make process, even the GNAT internal system - -- files (for example, the predefined Ada library files). By default, - -- GNAT MAKE does not check these files (however, if there is an - -- installation problem, it will be caught when GNAT MAKE binds your - -- program). You may have to specify this qualifier if you are working on - -- GNAT itself. The vast majority of GNAT MAKE users never need to - -- specify this switch. All GNAT internal files with will be compiled - -- with /STYLE_CHECK=GNAT. - - S_Make_Allproj : aliased constant S := "/ALL_PROJECTS " & - "-U"; - -- /NOALL_PROJECTS (D) - -- /ALL_PROJECTS - -- - -- Implies /Unique. - -- When used without project files, it is equivalent to /UNIQUE. - -- When used with a project file with no main (neither on the command - -- line nor in the attribute Main) check every source of every project, - -- recompile all sources that are not up to date and rebuild libraries - -- if necessary. - - S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" & - "-bargs BIND"; - -- /BINDER_QUALIFIERS - -- - -- Any qualifiers specified after this qualifier other than - -- /COMPILER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be - -- passed to any GNAT BIND commands generated by GNAT MAKE. - - S_Make_Bindprj : aliased constant S := "/BND_LNK_FULL_PROJECT " & - "-B"; - -- /BND_LNK_FULL_PROJECT - -- - -- Bind and link all sources of a project, without any consideration - -- to attribute Main, if there is one. This qualifier need to be - -- used in conjunction with the /PROJECT_FILE= qualifier and cannot - -- be used with a main subprogram on the command line or for - -- a library project file. As the binder is invoked with the option - -- meaning "No Ada main subprogram", the user must ensure that the - -- proper options are specified to the linker. This qualifier is - -- normally used when the main subprogram is in a foreign language - -- such as C. - - S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" & - "-cargs COMPILE"; - -- /COMPILER_QUALIFIERS - -- - -- Any qualifiers specified after this qualifier other than - -- /BINDER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be - -- passed to any GNAT COMPILE commands generated by GNAT MAKE. - - S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" & - "-A*"; - -- /CONDITIONAL_SOURCE_SEARCH=dir - -- - -- Equivalent to "/SOURCE_SEARCH=dir /SKIP_MISSING=dir". - - S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " & - "-k"; - -- /NOCONTINUE_ON_ERROR (D) - -- /CONTINUE_ON_ERROR - -- - -- Keep going. Continue as much as possible after a compilation error. - -- To ease the programmer's task in case of compilation errors, the list - -- of sources for which the compile fails is given when GNAT MAKE - -- terminates. - - S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- /NOCURRENT_DIRECTORY - -- - -- Look for source, library or object files in the default directory. - - S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " & - "-M"; - -- /NODEPENDENCIES_LIST (D) - -- /DEPENDENCIES_LIST - -- - -- Check if all objects are up to date. If they are, output the object - -- dependences to SYS$OUTPUT in a form that can be directly exploited in - -- a Unix-style Makefile. By default, each source file is prefixed with - -- its (relative or absolute) directory name. This name is whatever you - -- specified in the various /SOURCE_SEARCH and /SEARCH qualifiers. If - -- you also specify the /QUIET qualifier, only the source file names, - -- without relative paths, are output. If you just specify the - -- /DEPENDENCY_LIST qualifier, dependencies of the GNAT internal system - -- files are omitted. This is typically what you want. If you also - -- specify the /ALL_FILES qualifier, dependencies of the GNAT internal - -- files are also listed. Note that dependencies of the objects in - -- external Ada libraries (see the /SKIP_MISSING qualifier) are never - -- reported. - - S_Make_Dirobj : aliased constant S := "/DIRECTORY_OBJECTS=@" & - "-D@"; - -- /DIRECTORY_OBJECTS= - -- - -- Put all object files and .ALI files in . - -- This qualifier is not compatible with /PROJECT_FILE. - - S_Make_Disprog : aliased constant S := "/DISPLAY_PROGRESS " & - "-d"; - -- /NOPLAY_PROGRESS (D) - -- /DISPLAY_PROGRESS - -- - -- Display progress for each source, up to date or not, as a single line - -- completed x out of y (zz%) - -- If the file needs to be compiled this is displayed after the - -- invocation of the compiler. These lines are displayed even in quiet - -- output mode (/QUIET). - - S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " & - "-n"; - -- /NODO_OBJECT_CHECK (D) - -- /DO_OBJECT_CHECK - -- - -- Don't compile, bind, or link. Output a single command that will - -- recompile an out of date unit, if any. Repeated use of this option, - -- followed by carrying out the indicated compilation, will eventually - -- result in recompiling all required units. - -- - -- If any ALI is missing during the process, GNAT MAKE halts and - -- displays an error message. - - S_Make_Execut : aliased constant S := "/EXECUTABLE=@" & - "-o@"; - -- /EXECUTABLE=exec-name - -- - -- The name of the final executable program will be 'exec_name'. If this - -- qualifier is omitted the default name for the executable will be the - -- name of the input file with an EXE filetype. You may prefix - -- 'exec_name' with a relative or absolute directory path. - - S_Make_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Make_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Make_Force : aliased constant S := "/FORCE_COMPILE " & - "-f"; - -- /NOFORCE_COMPILE (D) - -- /FORCE_COMPILE - -- - -- Force recompilations. Recompile all sources, even though some object - -- files may be up to date, but don't recompile predefined or GNAT - -- internal files unless the /ALL_FILES qualifier is also specified. - - S_Make_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " & - "-F"; - -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D) - -- /FULL_PATH_IN_BRIEF_MESSAGES - -- - -- When using project files, if some errors or warnings are detected - -- during parsing and verbose mode is not in effect (no use of qualifier - -- /VERBOSE), then error lines start with the full path name of the - -- project file, rather than its simple file name. - - S_Make_Hi_Verb : aliased constant S := "/HIGH_VERBOSITY " & - "-vh"; - -- /NOHIGH_VERBOSITY (D) - -- /HIGH_VERBOSITY - -- - -- Displays the reason for all recompilations GNAT MAKE decides are - -- necessary, in high verbosity. Equivalent to /VERBOSE. - - S_Make_Inplace : aliased constant S := "/IN_PLACE " & - "-i"; - -- /NOIN_PLACE (D) - -- /IN_PLACE - -- - -- In normal mode, GNAT MAKE compiles all object files and ALI files - -- into the current directory. If the /IN_PLACE switch is used, - -- then instead object files and ALI files that already exist are over- - -- written in place. This means that once a large project is organized - -- into separate directories in the desired manner, then GNAT MAKE will - -- automatically maintain and update this organization. If no ALI files - -- are found on the Ada object path, the new object and ALI files are - -- created in the directory containing the source being compiled. - - S_Make_Index : aliased constant S := "/SOURCE_INDEX=#" & - "-eI#"; - -- /SOURCE_INDEX=nnn - -- - -- Specifies the index of the units in the source file - -- By default, source files are mono-unit and there is no index - -- When /SOURCE_INDEX=nnn is specified, only one main may be specified - -- on the command line. - - S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" & - "-L*"; - -- /LIBRARY_SEARCH=(directory[,...]) - -- - -- Add the specified directories to the list of directories in which the - -- linker will search for libraries. - - S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" & - "-largs LINK"; - -- /LINKER_QUALIFIERS - -- - -- Any qualifiers specified after this qualifier other than - -- /COMPILER_QUALIFIERS, /BINDER_QUALIFIERS and /MAKE_QUALIFIERS will be - -- passed to any GNAT LINK commands generated by GNAT LINK. - - S_Make_Low_Verb : aliased constant S := "/LOW_VERBOSITY " & - "-vl"; - -- /NOLOW_VERBOSITY (D) - -- /LOW_VERBOSITY - -- - -- Displays the reason for all recompilations GNAT MAKE decides are - -- necessary, in low verbosity, that is with less output than - -- /MEDIUM_VERBOSITY, /HIGH_VERBOSITY or /VERBOSE. - - S_Make_Make : aliased constant S := "/MAKE_QUALIFIERS=?" & - "-margs MAKE"; - -- /MAKE_QUALIFIERS - -- - -- Any qualifiers specified after this qualifier other than - -- /COMPILER_QUALIFIERS, /BINDER_QUALIFIERS and /LINKER_QUALIFIERS - -- are for the benefit of GNAT MAKE itself. - - S_Make_Mapping : aliased constant S := "/MAPPING " & - "-C"; - -- /NOMAPPING (D) - -- /MAPPING - -- - -- Use a mapping file. A mapping file is a way to communicate to the - -- compiler two mappings: from unit names to file names (without any - -- directory information) and from file names to path names (with full - -- directory information). These mappings are used by the compiler to - -- short-circuit the path search. When GNAT MAKE is invoked with this - -- qualifier, it will create a mapping file, initially populated by the - -- project manager, if /PROJECT_File= is used, otherwise initially empty. - -- Each invocation of the compiler will add the newly accessed sources to - -- the mapping file. This will improve the source search during the next - -- invocations of the compiler - - S_Make_Med_Verb : aliased constant S := "/MEDIUM_VERBOSITY " & - "-vm"; - -- /NOMEDIUM_VERBOSITY (D) - -- /MEDIUM_VERBOSITY - -- - -- Displays the reason for all recompilations GNAT MAKE decides are - -- necessary, in medium verbosity, that is with potentially less output - -- than /HIGH_VERBOSITY or /VERBOSE. - - S_Make_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " & - "-m"; - -- /NOMINIMAL_RECOMPILATION (D) - -- /MINIMAL_RECOMPILATION - -- - -- Specifies that the minimum necessary amount of recompilation - -- be performed. In this mode GNAT MAKE ignores time stamp differences - -- when the only modifications to a source file consist in - -- adding/removing comments, empty lines, spaces or tabs. - - S_Make_Missing : aliased constant S := "/CREATE_MISSING_DIRS " & - "-p"; - -- /NOCREATE_MISSING_DIRS (D) - -- /CREATE_MISSING_DIRS - -- - -- When an object directory, a library directory or an exec directory - -- in missing, attempt to create the directory. - - S_Make_Nolink : aliased constant S := "/NOLINK " & - "-c"; - -- /NOLINK - -- - -- Compile only. Do not perform binding and linking. If the root unit is - -- not a main unit, this is the default. Otherwise GNAT MAKE will - -- attempt binding and linking unless all objects are up to date and the - -- executable is more recent than the objects. - -- This is equivalent to /ACTIONS=COMPILE - - S_Make_Nomain : aliased constant S := "/NOMAIN " & - "-z"; - -- /NOMAIN - -- - -- No main subprogram. Bind and link the program even if the unit name - -- given on the command line is a package name. The resulting executable - -- will execute the elaboration routines of the package and its closure, - -- then the finalization routines. - - S_Make_Nonpro : aliased constant S := "/NON_PROJECT_UNIT_COMPILATION " & - "-x"; - -- /NON_PROJECT_UNIT_COMPILATION - -- - -- Normally, when using project files, a unit that is not part of any - -- project file, cannot be compile. These units may be compile, when - -- needed, if this qualifier is specified. - - S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; - -- /NOSTD_INCLUDES - -- - -- Do not look for sources the in the system default directory. - - S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & - "-nostdlib"; - -- /NOSTD_LIBRARIES - -- - -- Do not look for library files in the system default directory. - - S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" & - "-aO*"; - -- /OBJECT_SEARCH=(directory[,...]) - -- - -- When looking for library and object files look also in the specified - -- directories. - - S_Make_Proc : aliased constant S := "/PROCESSES=#" & - "-j#"; - -- /NOPROCESSES (D) - -- /PROCESSES=NNN - -- - -- Use NNN processes to carry out the (re)compilations. If you have a - -- multiprocessor machine, compilations will occur in parallel. In the - -- event of compilation errors, messages from various compilations might - -- get interspersed (but GNAT MAKE will give you the full ordered list of - -- failing compiles at the end). This can at times be annoying. To get a - -- clean list of error messages don't use this qualifier. - - S_Make_Nojobs : aliased constant S := "/NOPROCESSES " & - "-j1"; - -- NODOC (see /PROCESS) - - S_Make_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before any other processing to - -- set the building environment. - - S_Make_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- When this qualifiers is specified, the commands carried out by GNAT - -- MAKE are not displayed. - - S_Make_Reason : aliased constant S := "/REASONS " & - "-v"; - -- /NOREASONS (D) - -- /REASONS - -- - -- Displays the reason for all recompilations GNAT MAKE decides are - -- necessary. - - S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & - "--RTS=|"; - -- /RUNTIME_SYSTEM=xxx - -- - -- Build against an alternate runtime system named xxx or RTS-xxx. - - S_Make_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory[,...]) - -- - -- Search the specified directories for both source and object files. - - S_Make_Single : aliased constant S := "/SINGLE_COMPILE_PER_OBJ_DIR " & - "--single-compile-per-obj-dir"; - -- /NOSINGLE_COMPILE_PER_OBJ_DIR (D) - -- /SINGLE_COMPILE_PER_OBJ_DIR - -- - -- When project files are used, do not allow simultaneous compilations - -- for the same object directory. - - S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" & - "-aL*"; - -- /SKIP_MISSING=(directory[,...]) - -- - -- Skip missing library sources if ALI in 'directory'. - - S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" & - "-aI*"; - -- /SOURCE_SEARCH=(directory[,...]) - -- - -- When looking for source files also look in the specified directories. - - S_Make_Src_Info : aliased constant S := "/SRC_INFO=<" & - "--source-info=>"; - -- /SRC_INFO=source-info-file - -- - -- Specify a source info file to be read or written by the Project - -- Manager when project files are used. - - S_Make_Stand : aliased constant S := "/STANDARD_OUTPUT_FOR_COMMANDS " & - "-eS"; - -- /NOSTANDARD_OUTPUT_FOR_COMMANDS (D) - -- /STANDARD_OUTPUT_FOR_COMMANDS - -- - -- Output the commands for the compiler, the binder and the linker - -- on SYS$OUTPUT, instead of SYS$ERROR. - - S_Make_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Make_Switch : aliased constant S := "/SWITCH_CHECK " & - "-s"; - -- /NOSWITCH_CHECK (D) - -- /SWITCH_CHECK - -- - -- Recompile if compiler switches have changed since last compilation. - -- All compiler switches but -I and -o are taken into account in the - -- following way: orders between different "first letter" switches are - -- ignored, but orders between same switches are taken into account. - -- For example, -O -O2 is different than -O2 -O, but -g -O is equivalent - -- to -O -g. - - S_Make_USL : aliased constant S := "/UNCHECKED_SHARED_LIB_IMPORTS " & - "--unchecked-shared-lib-imports"; - -- /NOUNCHECKED_SHARED_LIB_IMPORTS (D) - -- /UNCHECKED_SHARED_LIB_IMPORTS - -- - -- Allow shared library projects to import static library projects - - S_Make_Unique : aliased constant S := "/UNIQUE " & - "-u"; - -- /NOUNIQUE (D) - -- /UNIQUE - -- - -- Recompile at most the main file. It implies /ACTIONS=COMPILE. - -- Combined with /FORCE_COMPILE, it is equivalent to calling the compiler - -- directly. - - S_Make_Use_Map : aliased constant S := "/USE_MAPPING_File=@" & - "-C=@"; - -- /USE_MAPPING_FILE=file_name - -- - -- Use a specific mapping file. The file 'file_name', specified as a path - -- name (absolute or relative) by this qualifier, should already exist, - -- otherwise the qualifier is ineffective. The specified mapping file - -- will be communicated to the compiler. This switch is not compatible - -- with a project file (/PROJECT_FILE=) or with multiple compiling - -- processes (/PROCESSES=nnn, when nnn is greater than 1). - - S_Make_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Displays the reason for all recompilations GNAT MAKE decides are - -- necessary. - - Make_Switches : aliased constant Switches := - (S_Make_Add 'Access, - S_Make_Actions 'Access, - S_Make_All 'Access, - S_Make_Allproj 'Access, - S_Make_Bind 'Access, - S_Make_Comp 'Access, - S_Make_Cond 'Access, - S_Make_Cont 'Access, - S_Make_Current 'Access, - S_Make_Dep 'Access, - S_Make_Dirobj 'Access, - S_Make_Disprog 'Access, - S_Make_Doobj 'Access, - S_Make_Execut 'Access, - S_Make_Ext 'Access, - S_Make_Follow 'Access, - S_Make_Force 'Access, - S_Make_Full 'Access, - S_Make_Hi_Verb 'Access, - S_Make_Inplace 'Access, - S_Make_Index 'Access, - S_Make_Library 'Access, - S_Make_Link 'Access, - S_Make_Low_Verb'Access, - S_Make_Make 'Access, - S_Make_Mapping 'Access, - S_Make_Med_Verb'Access, - S_Make_Mess 'Access, - S_Make_Minimal 'Access, - S_Make_Missing 'Access, - S_Make_Nolink 'Access, - S_Make_Nomain 'Access, - S_Make_Nonpro 'Access, - S_Make_Nostinc 'Access, - S_Make_Nostlib 'Access, - S_Make_Object 'Access, - S_Make_Proc 'Access, - S_Make_Nojobs 'Access, - S_Make_Project 'Access, - S_Make_Quiet 'Access, - S_Make_Reason 'Access, - S_Make_RTS 'Access, - S_Make_Search 'Access, - S_Make_Single 'Access, - S_Make_Skip 'Access, - S_Make_Source 'Access, - S_Make_Src_Info'Access, - S_Make_Stand 'Access, - S_Make_Subdirs 'Access, - S_Make_Switch 'Access, - S_Make_USL 'Access, - S_Make_Unique 'Access, - S_Make_Use_Map 'Access, - S_Make_Verbose 'Access); - - ------------------------------ - -- Switches for GNAT METRIC -- - ------------------------------ - - S_Metric_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Metric_All_Prjs : aliased constant S := "/ALL_PROJECTS " & - "-U"; - -- /NOALL_PROJECTS (D) - -- /ALL_PROJECTS - -- When GNAT METRIC is used with a Project File and no source is - -- specified, the underlying tool gnatmetric is called for all the - -- sources of all the Project Files in the project tree. - - S_Metric_Debug : aliased constant S := "/DEBUG_OUTPUT " & - "-dv"; - -- /DEBUG_OUTPUT - -- - -- Generate the debug information - - S_Metric_Direct : aliased constant S := "/DIRECTORY=@" & - "-d=@"; - -- /DIRECTORY=pathname - -- - -- Put the files with detailed metric information into the specified - -- directory - - S_Metric_Element : aliased constant S := "/ELEMENT_METRICS=" & - "ALL " & - "!-ed,!-es,!-enl,!-eps," & - "!-eas,!-ept,!-eat,!-enu," & - "!-ec " & - "DECLARATION_TOTAL " & - "-ed " & - "STATEMENT_TOTAL " & - "-es " & - "LOOP_NESTING_MAX " & - "-enl " & - "INT_SUBPROGRAMS " & - "-eps " & - "SUBPROGRAMS_ALL " & - "-eas " & - "INT_TYPES " & - "-ept " & - "TYPES_ALL " & - "-eat " & - "PROGRAM_NESTING_MAX " & - "-enu " & - "CONSTRUCT_NESTING_MAX " & - "-ec"; - -- NODOC (see /SYNTAX_METRICS) - - S_Metric_Syntax : aliased constant S := "/SYNTAX_METRICS=" & - "ALL " & - "--syntax-all " & - "NONE " & - "--no-syntax-all " & - "DECLARATIONS " & - "--declarations " & - "NODECLARATIONS " & - "--no-declarations " & - "STATEMENTS " & - "--statements " & - "NOSTATEMENTS " & - "--no-statements " & - "PUBLIC_SUBPROGRAMS " & - "--public-subprograms " & - "NOPUBLIC_SUBPROGRAMS " & - "--no-public-subprograms " & - "ALL_SUBPROGRAMS " & - "--all-subprograms " & - "NOALL_SUBPROGRAMS " & - "--no-all-subprograms " & - "PUBLIC_TYPES " & - "--public-types " & - "NOPUBLIC_TYPES " & - "--no-public-types " & - "ALL_TYPES " & - "--all-types " & - "NOALL_TYPES " & - "--no-all-types " & - "UNIT_NESTING " & - "--unit-nesting " & - "NOUNIT_NESTING " & - "--no-unit-nesting " & - "CONSTRUCT_NESTING " & - "--construct-nesting " & - "NOCONSTRUCT_NESTING " & - "--no-construct-nesting"; - -- /SYNTAX_METRICS(option, option ...) - -- - -- Specifies the syntax element metrics to be computed (if at least one - -- positive syntax element metric, line metric, complexity or coupling - -- metric is specified then only explicitly specified syntax element - -- metrics are computed and reported) - -- - -- option may be one of the following: - -- - -- ALL (D) All the syntax element metrics are computed - -- NONE None of syntax element metrics is computed - -- DECLARATIONS Compute the total number of declarations - -- NODECLARATIONS Do not compute the total number of declarations - -- STATEMENTS Compute the total number of statements - -- NOSTATEMENTS Do not compute the total number of statements - -- PUBLIC_SUBPROGRAMS Compute the number of public subprograms - -- NOPUBLIC_SUBPROGRAMS Do not compute the number of public subprograms - -- ALL_SUBPROGRAMS Compute the number of all the subprograms - -- NOALL_SUBPROGRAMS Do not compute the number of all the - -- subprograms - -- PUBLIC_TYPES Compute the number of public types - -- NOPUBLIC_TYPES Do not compute the number of public types - -- ALL_TYPES Compute the number of all the types - -- NOALL_TYPES Do not compute the number of all the types - -- UNIT_NESTING Compute the maximal program unit nesting - -- level - -- NOUNIT_NESTING Do not compute the maximal program unit - -- nesting level - -- CONSTRUCT_NESTING Compute the maximal construct nesting level - -- NOCONSTRUCT_NESTING Do not compute the maximal construct nesting - -- level - -- - -- All combinations of syntax element metrics options are allowed. - - S_Metric_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Metric_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Metric_Format : aliased constant S := "/FORMAT_OUTPUT=" & - "DEFAULT " & - "!-x,!-nt,!-sfn " & - "XML " & - "-x " & - "XSD " & - "-xs " & - "NO_TEXT " & - "-nt " & - "SHORT_SOURCE_FILE_NAME " & - "-sfn"; - -- /FORMAT_OUTPUT=(option, option ...) - -- - -- Specifies the details of the tool output - -- - -- option may be one of the following: - -- - -- DEFAULT (D) Generate the text output only, use full - -- argument source names in global information - -- XML Generate the output in XML format - -- XSD Generate the output in XML format, and - -- generate an XML schema file that describes - -- the structure of XML metrics report - -- NO_TEXT Do not generate the text output (implies XML) - -- SHORT_SOURCE_FILE_NAME Use short argument source names in output - - S_Metric_Globout : aliased constant S := "/GLOBAL_OUTPUT=@" & - "-og@"; - -- /GLOBAL_OUTPUT=filename - -- - -- Put the textual global metric information into the specified file - - S_Metric_Line : aliased constant S := "/LINE_METRICS=" & - "ALL " & - "!-la,!-lcode,!-lcomm," & - "!-leol,!-lb " & - "LINES_ALL " & - "-la " & - "CODE_LINES " & - "-lcode " & - "COMENT_LINES " & - "-lcomm " & - "MIXED_CODE_COMMENTS " & - "-leol " & - "COMMENT_PERCENTAGE " & - "-lratio " & - "BLANK_LINES " & - "-lb " & - "AVERAGE_LINES_IN_BODIES " & - "-lav "; - -- NODOC (see /LINE_COUNT_METRICS) - - S_Metric_Lines : aliased constant S := "/LINE_COUNT_METRICS=" & - "ALL " & - "--lines-all " & - "NONE " & - "--no-lines-all " & - "ALL_LINES " & - "--lines " & - "NOALL_LINES " & - "--no-lines " & - "CODE_LINES " & - "--lines-code " & - "NOCODE_LINES " & - "--no-lines-code " & - "COMMENT_LINES " & - "--lines-comment " & - "NOCOMMENT_LINES " & - "--no-lines-comment " & - "CODE_COMMENT_LINES " & - "--lines-eol-comment " & - "NOCODE_COMMENT_LINES " & - "--no-lines-eol-comment " & - "COMMENT_PERCENTAGE " & - "--lines-ratio " & - "NOCOMMENT_PERCENTAGE " & - "--no-lines-ratio " & - "BLANK_LINES " & - "--lines-blank " & - "NOBLANK_LINES " & - "--no-lines-blank " & - "AVERAGE_BODY_LINES " & - "--lines-average " & - "NOAVERAGE_BODY_LINES " & - "--no-lines-average"; - -- /LINE_COUNT_METRICS=(option, option ...) - - -- Specifies the line metrics to be computed (if at least one positive - -- syntax element metric, line metric, complexity or coupling metric is - -- specified then only explicitly specified line metrics are computed - -- and reported) - -- - -- option may be one of the following: - -- - -- ALL (D) All the line metrics are computed - -- NONE None of line metrics is computed - -- ALL_LINES All lines are computed - -- NOALL_LINES All lines are not computed - -- CODE_LINES Lines with Ada code are computed - -- NOCODE_LINES Lines with Ada code are not computed - -- COMMENT_LINES Comment lines are computed - -- NOCOMMENT_LINES Comment lines are not computed - -- CODE_COMMENT_LINES Lines containing both code and comment parts - -- are computed - -- NOCODE_COMMENT_LINES Lines containing both code and comment parts - -- are not computed - -- COMMENT_PERCENTAGE Ratio between comment lines and all the lines - -- containing comments and program code is - -- computed - -- NOCOMMENT_PERCENTAGE Ratio between comment lines and all the lines - -- containing comments and program code is not - -- computed - -- BLANK_LINES Blank lines are computed - -- NOBLANK_LINES Blank lines are not computed - -- AVERAGE_BODY_LINES Average number of code lines in subprogram, - -- task and entry bodies and statement sequences - -- of package bodies is computed - -- NOAVERAGE_BODY_LINES Average number of code lines in subprogram, - -- task and entry bodies and statement sequences - -- of package bodies is not computed - -- - -- All combinations of line metrics options are allowed. - - S_Metric_Complexity : aliased constant S := "/COMPLEXITY_METRICS=" & - "ALL " & - "--complexity-all " & - "NONE " & - "--no-complexity-all " & - "CYCLOMATIC " & - "--complexity-cyclomatic " & - "NOCYCLOMATIC " & - "--no-complexity-cyclomatic " & - "ESSENTIAL " & - "--complexity-essential " & - "NOESSENTIAL " & - "--no-complexity-essential " & - "LOOP_NESTING " & - "--loop-nesting " & - "NOLOOP_NESTING " & - "--no-loop-nesting " & - "AVERAGE_COMPLEXITY " & - "--complexity-average " & - "NOAVERAGE_COMPLEXITY " & - "--no-complexity-average " & - "EXTRA_EXIT_POINTS " & - "--extra-exit-points " & - "NOEXTRA_EXIT_POINTS " & - "--no-extra-exit-points"; - -- /COMPLEXITY_METRICS=(option, option ...) - - -- Specifies the complexity metrics to be computed (if at least one - -- positive syntax element metric, line metric, complexity or coupling - -- metric is specified then only explicitly specified complexity metrics - -- are computed and reported) - -- - -- option may be one of the following: - -- - -- ALL (D) All the complexity metrics are computed - -- NONE None of complexity metrics is computed - -- CYCLOMATIC Compute the McCabe Cyclomatic Complexity - -- NOCYCLOMATIC Do not compute the McCabe Cyclomatic Complexity - -- ESSENTIAL Compute the Essential Complexity - -- NOESSENTIAL Do not compute the Essential Complexity - -- LOOP_NESTING Compute the maximal loop nesting - -- NOLOOP_NESTING Do not compute the maximal loop nesting - -- AVERAGE_COMPLEXITY Compute the average complexity for executable - -- bodies - -- NOAVERAGE_COMPLEXITY Do not compute the average complexity for - -- executable bodies - -- EXTRA_EXIT_POINTS Compute extra exit points metric - -- NOEXTRA_EXIT_POINTS Do not compute extra exit points metric - -- - -- All combinations of line metrics options are allowed. - - S_Metric_Coupling : aliased constant S := "/COUPLING_METRICS=" & - "ALL " & - "--coupling-all " & - "TAGGED_OUT " & - "--tagged-coupling-out " & - "TAGGED_IN " & - "--tagged-coupling-in " & - "HIERARCHY_OUT " & - "--hierarchy-coupling-out " & - "HIERARCHY_IN " & - "--hierarchy-coupling-in " & - "UNIT_OUT " & - "--unit-coupling-out " & - "UNIT_IN " & - "--unit-coupling-in " & - "CONTROL_OUT " & - "--control-coupling-out " & - "CONTROL_IN " & - "--control-coupling-in"; - - -- /COUPLING_METRICS=(option, option ...) - - -- Specifies the coupling metrics to be computed. - -- - -- option may be one of the following: - -- - -- ALL All the coupling metrics are computed - -- NOALL (D) None of coupling metrics is computed - -- TAGGED_OUT Compute tagged (class) far-out coupling - -- TAGGED_IN Compute tagged (class) far-in coupling - -- HIERARCHY_OUT Compute hieraqrchy (category) far-out coupling - -- HIERARCHY_IN Compute hieraqrchy (category) far-in coupling - -- UNIT_OUT Compute unit far-out coupling - -- UNIT_IN Compute unit far-in coupling - -- CONTROL_OUT Compute control far-out coupling - -- CONTROL_IN Compute control far-in coupling - - -- - -- All combinations of coupling metrics options are allowed. - - S_Metric_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Metric_No_Local : aliased constant S := "/NO_LOCAL_DETAILS " & - "-nolocal"; - -- /LOCAL_DETAILS (D) - -- /NO_LOCAL_DETAILS - -- - -- Do not compute the detailed metrics for local program units. - - S_Metric_No_Exits_As_Gotos : aliased constant S := "/NO_EXITS_AS_GOTOS " & - "-ne"; - -- /EXITS_AS_GOTOS (D) - -- /NO_EXITS_AS_GOTOS - -- - -- Do not count EXIT statements as GOTOs when computing the Essential - -- Complexity. - - S_Metric_No_Static_Loop : aliased constant S := "/NO_STATIC_LOOP " & - "--no-static-loop"; - -- /STATIC_LOOP (D) - -- /NO_STATIC_LOOP - -- - -- Do not count static FOR loop statements when computing the Cyclomatic - -- Complexity. - - S_Metric_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Metric_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- binder. - - S_Metric_Processes : aliased constant S := "/PROCESSES=#" & - "-j#"; - - -- /NOPROCESSES (D) - -- /PROCESSES=NNN - -- - -- Use NNN processes to carry out the tree creations (internal - -- representations of the argument sources). On a multiprocessor machine - -- this speeds up processing of big sets of argument sources. If NNN is 0, - -- then the maximum number of parallel tree creations is the number of - -- core processors on the platform. - - S_Metric_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Quiet mode: by default GNAT METRIC outputs to the standard error stream - -- the number of program units left to be processed. This option turns - -- this trace off. - - S_Metric_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Metric_Suffix : aliased constant S := "/SUFFIX_DETAILS=" & '"' & - "-o" & '"'; - -- /SUFFIX_DETAILS=suffix - -- - -- Use the given suffix as the suffix for the name of the file to place - -- the detailed metrics into. - - S_Metric_Suppress : aliased constant S := "/SUPPRESS=" & - "NOTHING " & - "!-nocc,!-noec,!-nonl," & - "!-ne,!-nolocal " & - "CYCLOMATIC_COMPLEXITY " & - "-nocc " & - "ESSENTIAL_COMPLEXITY " & - "-noec " & - "MAXIMAL_LOOP_NESTING " & - "-nonl " & - "EXITS_AS_GOTOS " & - "-ne " & - "LOCAL_DETAILS " & - "-nolocal "; - -- NODOC (see /COMPLEXITY_METRICS /NO_LOCAL_DETAILS /NO_EXITS_AS_GOTOS) - - S_Metric_Time : aliased constant S := "/TIME " & - "-t"; - -- /NOTIME (D) - -- /TIME - -- - -- Print out execution time - - S_Metric_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Verbose mode. - - S_Metric_XMLout : aliased constant S := "/XML_OUTPUT=@" & - "-ox@"; - -- /XML_OUTPUT=filename - -- - -- Place the XML output into the specified file - - Metric_Switches : aliased constant Switches := - (S_Metric_Add 'Access, - S_Metric_All_Prjs 'Access, - S_Metric_Complexity 'Access, - S_Metric_Coupling 'Access, - S_Metric_Debug 'Access, - S_Metric_Direct 'Access, - S_Metric_Element 'Access, - S_Metric_Ext 'Access, - S_Metric_Files 'Access, - S_Metric_Follow 'Access, - S_Metric_Format 'Access, - S_Metric_Globout 'Access, - S_Metric_Line 'Access, - S_Metric_Lines 'Access, - S_Metric_Mess 'Access, - S_Metric_No_Exits_As_Gotos'Access, - S_Metric_No_Local 'Access, - S_Metric_No_Static_Loop 'Access, - S_Metric_Project 'Access, - S_Metric_Processes 'Access, - S_Metric_Quiet 'Access, - S_Metric_Suffix 'Access, - S_Metric_Subdirs 'Access, - S_Metric_Syntax 'Access, - S_Metric_Suppress 'Access, - S_Metric_Time 'Access, - S_Metric_Verbose 'Access, - S_Metric_XMLout 'Access); - - ---------------------------- - -- Switches for GNAT NAME -- - ---------------------------- - - S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" & - "-c>"; - -- /CONFIG_FILE=path_name - -- - -- Create a configuration pragmas file 'path_name' (instead of the default - -- 'gnat.adc'). 'path_name' may include directory information. 'path_name' - -- must be writable. There may be only one qualifier /CONFIG_FILE. - -- This qualifier is not compatible with qualifier /PROJECT_FILE. - - S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" & - "-d*"; - -- /SOURCE_DIRS=(directory, ...) - -- - -- Look for source files in the specified directories. When this qualifier - -- is specified, the current working directory will not be searched for - -- source files, unless it is explicitly specified with a qualifier - -- /SOURCE_DIRS or /DIRS_FILE. Several qualifiers /SOURCE_DIRS may be - -- specified. If a directory is specified as a relative path, it is - -- relative to the directory of the configuration pragmas file specified - -- with qualifier /CONFIG_FILE, or to the directory of the project file - -- specified with qualifier /PROJECT_FILE or, if neither qualifier - -- /CONFIG_FILE nor qualifier /PROJECT_FILE are specified, it is relative - -- to the current working directory. The directories specified with - -- qualifiers /SOURCE_DIRS must exist and be readable. - - S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" & - "-D>"; - -- /DIRS_FILE=file_name - -- - -- Look for source files in all directories listed in text file - -- 'file_name'. 'file_name' must be an existing, readable text file. - -- Each non empty line in the specified file must be a directory. - -- Specifying qualifier /DIRS_FILE is equivalent to specifying as many - -- qualifiers /SOURCE_DIRS as there are non empty lines in the specified - -- text file. - - S_Name_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Name_Frng : aliased constant S := "/FOREIGN_PATTERN=" & '"' & - "-f" & '"'; - -- /FOREIGN_PATTERN= - -- - -- Specify a foreign pattern. - -- Using this qualifier, it is possible to add sources of languages other - -- than Ada to the list of sources of a project file. It is only useful - -- if a qualifier /PROJECT_FILE is used. For example, - -- - -- GNAT NAME /PROJECT_FILE=PRJ /FOREIGN_PATTERN="*.C" "*.ADA" - -- - -- will look for Ada units in all files with the '.ADA' extension, and - -- will add to the list of file for project PRJ.GPR the C files with - -- extension ".C". - - S_Name_Help : aliased constant S := "/HELP " & - "-h"; - -- /NOHELP (D) - -- /HELP - -- - -- Output usage information to the standard output stream. - - S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=file_name - -- - -- Create or update a project file. 'file_name' may include directory - -- information. The specified file must be writable. There may be only - -- one qualifier /PROJECT_FILE. When a qualifier /PROJECT_FILE is - -- specified, no qualifier /CONFIG_FILE may be specified. - - S_Name_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Name_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Verbose mode. Output detailed explanation of behavior to the standard - -- output stream. This includes name of the file written, the name of the - -- directories to search and, for each file in those directories whose - -- name matches at least one of the Naming Patterns, an indication of - -- whether the file contains a unit, and if so the name of the unit. - - S_Name_Excl : aliased constant S := "/EXCLUDED_PATTERN=" & '"' & - "-x" & '"'; - -- /EXCLUDED_PATTERN= - -- - -- Specify an excluded pattern. - -- Using this qualifier, it is possible to exclude some files that would - -- match the Naming patterns. For example, - -- - -- GNAT NAME /EXCLUDED_PATTERN="*_NT.ADA" "*.ADA" - -- - -- will look for Ada units in all files with the '.ADA' extension, except - -- those whose names end with '_NT.ADA'. - - Name_Switches : aliased constant Switches := - (S_Name_Conf 'Access, - S_Name_Dirs 'Access, - S_Name_Dfile 'Access, - S_Name_Follow 'Access, - S_Name_Frng 'Access, - S_Name_Help 'Access, - S_Name_Proj 'Access, - S_Name_Subdirs 'Access, - S_Name_Verbose 'Access, - S_Name_Excl 'Access); - - ---------------------------------- - -- Switches for GNAT PREPROCESS -- - ---------------------------------- - - S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' & - "-D" & '"'; - -- /ASSOCIATE="name=val" - -- - -- Defines a new symbol, associated with value. If no value is given - -- on the command line, then symbol is considered to be True. - -- This qualifier can be used in place of a definition file. - - S_Prep_Blank : aliased constant S := "/BLANK_LINES " & - "-b"; - -- /NOBLANK_LINES (D) - -- /BLANK_LINES - -- - -- Causes both preprocessor lines and the lines deleted by preprocessing - -- to be replaced by blank lines in the output source file, thus - -- preserving line numbers in the output file. - - S_Prep_Com : aliased constant S := "/COMMENTS " & - "-c"; - -- /NOCOMMENTS (D) - -- /COMMENTS - -- - -- /COMMENTS causes both preprocessor lines and the lines deleted - -- by preprocessing to be retained in the output source as comments marked - -- with the special string "--! ". This option will result in line numbers - -- being preserved in the output file. - -- - -- /NOCOMMENTS causes both preprocessor lines and the lines deleted by - -- preprocessing to be replaced by blank lines in the output source file, - -- thus preserving line numbers in the output file. - - S_Prep_Ref : aliased constant S := "/REFERENCE " & - "-r"; - -- /NOREFERENCE (D) - -- /REFERENCE - -- - -- Causes a "Source_Reference" pragma to be generated that references the - -- original input file, so that error messages will use the file name of - -- this original file. Also implies /BLANK_LINES if /COMMENTS is not - -- specified. - - S_Prep_Remove : aliased constant S := "/REMOVE " & - "!-b,!-c"; - -- /REMOVE (D) - -- /NOREMOVE - -- - -- Preprocessor lines and deleted lines are completely removed from the - -- output. - - S_Prep_Replace : aliased constant S := "/REPLACE_IN_COMMENTS " & - "-C"; - -- /NOREPLACE_IN_COMMENTS (D) - -- /REPLACE_IN_COMMENTS - -- - -- Causes preprocessor to scan comments and perform replacements on - -- any $symbol occurrences within the comment text. - - S_Prep_Symbols : aliased constant S := "/SYMBOLS " & - "-s"; - -- /NOSYMBOLS (D) - -- /SYMBOLS - -- - -- Causes a sorted list of symbol names and values to be listed on - -- SYS$OUTPUT. - - S_Prep_Undef : aliased constant S := "/UNDEFINED " & - "-u"; - -- /NOUNDEFINED (D) - -- /UNDEFINED - - Prep_Switches : aliased constant Switches := - (S_Prep_Assoc 'Access, - S_Prep_Blank 'Access, - S_Prep_Com 'Access, - S_Prep_Ref 'Access, - S_Prep_Remove 'Access, - S_Prep_Replace 'Access, - S_Prep_Symbols 'Access, - S_Prep_Undef 'Access); - - ------------------------------ - -- Switches for GNAT PRETTY -- - ------------------------------ - - S_Pretty_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Pretty_Align : aliased constant S := "/ALIGN=" & - "DEFAULT " & - "-A12345 " & - "OFF " & - "-A0 " & - "COLONS " & - "-A1 " & - "DECLARATIONS " & - "-A2 " & - "STATEMENTS " & - "-A3 " & - "ARROWS " & - "-A4 " & - "COMPONENT_CLAUSES " & - "-A5"; - -- /ALIGN[=align-option, align-option, ...] - -- - -- Set alignments. By default, all alignments (colons in declarations, - -- initialisations in declarations, assignments and arrow delimiters) are - -- ON. - -- - -- align-option may be one of the following: - -- - -- OFF (D) Set all alignments to OFF - -- COLONS Set alignments of colons in declarations to ON - -- DECLARATIONS Set alignments of initialisations in declarations - -- to ON - -- STATEMENTS Set alignments of assignments statements to ON - -- ARROWS Set alignments of arrow delimiters to ON. - -- COMPONENT_CLAUSES Set alignments of AT keywords in component - -- clauses ON - -- - -- Specifying one of the ON options without first specifying the OFF - -- option has no effect, because by default all alignments are set to ON. - - S_Pretty_All_Prjs : aliased constant S := "/ALL_PROJECTS " & - "-U"; - -- /NOALL_PROJECTS (D) - -- /ALL_PROJECTS - -- When GNAT PRETTY is used with a Project File and no source is - -- specified, the underlying tool gnatpp is called for all the - -- sources of all the Project Files in the project tree. - - S_Pretty_Attrib : aliased constant S := "/ATTRIBUTE_CASING=" & - "MIXED_CASE " & - "-aM " & - "LOWER_CASE " & - "-aL " & - "UPPER_CASE " & - "-aU"; - -- /ATTRIBUTE_CASING[=casing-option] - -- - -- Set the case of the attributes. By default the attributes are in mixed - -- case. - -- casing-option may be one of the following: - -- - -- MIXED_CASE (D) - -- LOWER_CASE - -- UPPER_CASE - - S_Pretty_Comments : aliased constant S := "/COMMENTS_LAYOUT=" & - "UNTOUCHED " & - "-c0 " & - "DEFAULT " & - "-c1 " & - "STANDARD_INDENT " & - "-c2 " & - "GNAT_BEGINNING " & - "-c3 " & - "REFORMAT " & - "-c4 " & - "KEEP_SPECIAL " & - "-c5"; - -- /COMMENTS_LAYOUT[=layout-option, layout-option, ...] - -- - -- Set the comment layout. By default, comments use the GNAT style - -- comment line indentation. - -- - -- layout-option may be one of the following: - -- - -- UNTOUCHED All the comments remain unchanged - -- DEFAULT (D) GNAT style comment line indentation - -- STANDARD_INDENT Standard comment line indentation - -- GNAT_BEGINNING GNAT style comment beginning - -- REFORMAT Reformat comment blocks - -- KEEP_SPECIAL Keep unchanged special form comments - -- - -- All combinations of layout options are allowed, except for DEFAULT - -- and STANDARD_INDENT which are mutually exclusive, and also if - -- UNTOUCHED is specified, this must be the only option. - -- - -- The difference between "GNAT style comment line indentation" and - -- "standard comment line indentation" is the following: for standard - -- comment indentation, any comment line is indented as if it were - -- a declaration or statement at the same place. - -- For GNAT style comment indentation, comment lines which are - -- immediately followed by if or case statement alternative, record - -- variant or 'begin' keyword are indented as the keyword that follows - -- them.: - -- - -- Standard indentation: - -- - -- if A then - -- null; - -- -- some comment - -- else - -- null; - -- end if; - -- - -- GNAT style indentation: - -- - -- if A then - -- null; - -- -- some comment - -- else - -- null; - -- end if; - -- - -- Option "GNAT style comment beginning" means that for each comment - -- which is not considered as non-formattable separator (that is, the - -- comment line contains only dashes, or a comment line ends with two - -- dashes), there will be at least two spaces between starting "--" and - -- the first non-blank character of the comment. - - S_Pretty_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & - "-gnatec>"; - -- /CONFIGURATION_PRAGMAS_FILE=file - -- - -- Specify a configuration pragmas file that need to be passed to the - -- compiler. - - S_Pretty_Constr : aliased constant S := "/CONSTRUCT_LAYOUT=" & - "GNAT " & - "-l1 " & - "COMPACT " & - "-l2 " & - "UNCOMPACT " & - "-l3"; - -- /CONSTRUCT_LAYOUT[=construct-option] - -- - -- Set construct layout. Default is GNAT style layout. - -- construct-option may be one of the following: - -- - -- GNAT (D) - -- COMPACT - -- UNCOMPACT - -- - -- The difference between GNAT style and Compact layout on one hand - -- and Uncompact layout on the other hand can be illustrated by the - -- following examples: - -- - -- GNAT style and Uncompact layout - -- Compact layout - -- - -- type q is record type q is - -- a : integer; record - -- b : integer; a : integer; - -- end record; b : integer; - -- end record; - -- - -- - -- Block : declare Block : - -- A : Integer := 3; declare - -- begin A : Integer := 3; - -- Proc (A, A); begin - -- end Block; Proc (A, A); - -- end Block; - -- - -- Clear : for J in 1 .. 10 loop Clear : - -- A (J) := 0; for J in 1 .. 10 loop - -- end loop Clear; A (J) := 0; - -- end loop Clear; - -- - -- - -- A further difference between GNAT style layout and compact layout is - -- that in GNAT style layout compound statements, return statements and - -- bodies are always separated by empty lines. - - S_Pretty_Comind : aliased constant S := "/CONTINUATION_INDENT=#" & - "-cl#"; - -- /CONTINUATION_INDENT=nnn - -- - -- Indentation level for continuation lines, nnn from 1 .. 9. - -- The default value is one less than the (normal) indentation level, - -- unless the indentation is set to 1: in that case the default value for - -- continuation line indentation is also 1. - - S_Pretty_Compact_Is : aliased constant S := "/NO_SEPARATE_IS " & - "--no-separate-is"; - -- /NO_SEPARATE_IS - -- - -- Do not place the IS keyword on a separate line in a subprogram body in - -- case if the specification occupies more than one line. - - S_Pretty_Sep_Label : aliased constant S := "/SEPARATE_LABEL " & - "--separate-label"; - -- /SEPARATE_LABEL - -- - -- Place statement label(s) and the statement itself on separate lines. - - S_Pretty_Sep_Loop_Then : aliased constant S := "/SEPARATE_LOOP_THEN " & - "--separate-loop-then"; - -- /SEPARATE_LOOP_THEN - -- - -- Place the THEN keyword in IF statement and the LOOP keyword in for- - -- and while-loops on a separate line. - - S_Pretty_N_Sep_Loop_Then : aliased constant S := "/NO_SEPARATE_LOOP_THEN " & - "--no-separate-loop-then"; - -- /NO_SEPARATE_LOOP_THEN - -- - -- Do not place the THEN keyword in IF statement and the LOOP keyword in - -- for- and while-loops on a separate line. - - S_Pretty_Use_On_New_Line : aliased constant S := "/USE_ON_NEW_LINE " & - "--use-on-new-line"; - -- /USE_ON_NEW_LINE - -- - -- Start any USE clause that is a part of a context clause from a - -- separate line. - - S_Pretty_Stnm_On_Nw_Line : aliased constant S := "/STMT_NAME_ON_NEW_LINE " & - "--separate-stmt-name"; - -- /STMT_NAME_ON_NEW_LINE - -- - -- For named block and loop statements use a separate line for the - -- statement name, but do not use an extra indentation level for the - -- statement itself. - - S_Pretty_Eol : aliased constant S := "/END_OF_LINE=" & - "DOS " & - "--eol=dos " & - "UNIX " & - "--eol=unix " & - "CRLF " & - "--eol=crlf " & - "LF " & - "--eol=lf"; - -- /END_OF_LINE=[option] - -- - -- Specifies the form of the line terminators in the produced source. - -- By default, the form of the line terminator depends on the platforms. - -- On Unix and VMS, it is a Line Feed (LF) character. On Windows (DOS), - -- It is a Carriage Return (CR) followed by a Line Feed. - - -- The Options DOS and CRLF are equivalent. The options UNIX and LF are - -- also equivalent. - - S_Pretty_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Pretty_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- - -- Look for source files in the current working directory. - -- - -- /NOCURRENT_DIRECTORY - -- Do not look for source files in the current working directory. - - S_Pretty_Dico : aliased constant S := "/DICTIONARY=*" & - "-D*"; - -- /DICTIONARY=(file_name, ...) - -- - -- Use each specified file as a dictionary file that defines the casing - -- for a set of specified names, thereby overriding the effect on these - -- names by any explicit or implicit /NAME_CASING qualifier. - -- - -- GNAT PRETTY implicitly uses a default dictionary file to define the - -- casing for the Ada predefined names and the names declared in the GNAT - -- libraries. - -- - -- The structure of a dictionary file, and details on the conventions - -- used in the default dictionary file, are defined in the GNAT User's - -- Guide. - - S_Pretty_Encoding : aliased constant S := "/RESULT_ENCODING=" & - "BRACKETS " & - "-Wb " & - "HEX " & - "-Wh " & - "UPPER " & - "-Wu " & - "SHIFT_JIS " & - "-Ws " & - "EUC " & - "-We " & - "UTF8 " & - "-W8"; - -- /RESULT_ENCODING[=encoding-type] - -- - -- Specify the wide character encoding method used when writing the - -- reformatted code in the result file. 'encoding-type' is one of the - -- following: - -- - -- BRACKETS (D) Brackets encoding. - -- - -- HEX Hex ESC encoding. - -- - -- UPPER Upper half encoding. - -- - -- SHIFT_JIS Shift-JIS encoding. - -- - -- EUC EUC Encoding. - -- - -- UTF8 UTF-8 encoding. - -- - -- See 'HELP GNAT COMPILE /WIDE_CHARACTER_ENCODING' for an explanation - -- about the different character encoding methods. - - S_Pretty_Enums : aliased constant S := "/ENUM_CASING=" & - "AS_DECLARED " & - "-neD " & - "LOWER_CASE " & - "-neL " & - "UPPER_CASE " & - "-neU " & - "MIXED_CASE " & - "-neM"; - -- /ENUM_CASING=name-option - -- - -- Specify the casing of enumeration literals. If not specified, the - -- casing of enumeration literals is defined by the NAME_CASING option. - -- 'name-option' may be one of: - -- - -- AS_DECLARED Literals casing for defining occurrences are - -- as they appear in the source file. - -- - -- LOWER_CASE Literals are in lower case. - -- - -- UPPER_CASE Literals are in upper case. - -- - -- MIXED_CASE Literals are in mixed case. - - S_Pretty_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Pretty_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Pretty_Forced : aliased constant S := "/FORCED_OUTPUT=@" & - "-of@"; - -- /FORCED_OUTPUT=file - -- - -- Write the output into the specified file, overriding any possibly - -- existing file. - - S_Pretty_Formfeed : aliased constant S := "/FORM_FEED_AFTER_PRAGMA_PAGE " & - "-ff"; - -- /FORM_FEED_AFTER_PRAGMA_PAGE - -- - -- When there is a pragma Page in the source, insert a Form Feed - -- character immediately after the semicolon that follows the pragma - -- Page. - - S_Pretty_Indent : aliased constant S := "/INDENTATION_LEVEL=#" & - "-i#"; - -- /INDENTATION_LEVEL=nnn - -- - -- Specify the number of spaces to add for each indentation level. - -- nnn must be between 1 and 9. The default is 3. - - S_Pretty_Keyword : aliased constant S := "/KEYWORD_CASING=" & - "LOWER_CASE " & - "-kL " & - "UPPER_CASE " & - "-kU"; - -- /KEYWORD_CASING[=keyword-option] - -- - -- Specify the case of Ada keywords. The default is keywords in lower - -- case. - -- - -- keyword-option may be one of the following: - -- - -- LOWER_CASE (D) - -- UPPER_CASE - - S_Pretty_Maxlen : aliased constant S := "/LINE_LENGTH_MAX=#" & - "-M#"; - -- /LINE_LENGTH_MAX=nnn - -- - -- Set the maximum line length, nnn from 32 ..256. The default is 79. - - S_Pretty_Maxact : aliased constant S := "/MAX_ACT=#" & - "--call_threshold=#"; - -- /MAX_ACT=nnn - -- - -- If the number of parameter associations is greater than nnn and if at - -- least one association uses named notation, start each association from - -- a new line - - S_Pretty_Maxind : aliased constant S := "/MAX_INDENT=#" & - "-T#"; - -- /MAX_INDENT=nnn - -- - -- Do not use an additional indentation level for case alternatives - -- and variants if their number is nnn or more. The default is 10. - -- If nnn is zero, an additional indentation level is used for any - -- number of case alternatives and variants. - - S_Pretty_Maxpar : aliased constant S := "/MAX_PAR=#" & - "--par_threshold=#"; - -- /MAX_PAR=nnn - -- - -- If the number of parameter specifications is greater than nnn (or equal - -- to nnn in case of a function), start each specification from a new line. - -- The default value is 3. - - S_Pretty_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Pretty_Names : aliased constant S := "/NAME_CASING=" & - "AS_DECLARED " & - "-nD " & - "LOWER_CASE " & - "-nL " & - "UPPER_CASE " & - "-nU " & - "MIXED_CASE " & - "-nM"; - -- /NAME_CASING[=name-option] - -- - -- Specify the casing of names. - -- 'name-option' may be one of: - -- - -- AS_DECLARED (D) Name casing for defining occurrences are as they - -- appear in the source file. - -- - -- LOWER_CASE Names are in lower case. - -- - -- UPPER_CASE Names are in upper case. - -- - -- MIXED_CASE Names are in mixed case. - - S_Pretty_Replace_No_Backup : aliased constant S := "/REPLACE_NO_BACKUP " & - "-rnb"; - -- /REPLACE_NO_BACKUP - -- - -- Replace the argument source with the pretty-printed source without - -- creating any backup copy of the argument source. - - S_Pretty_No_Labels : aliased constant S := "/NO_MISSED_LABELS " & - "-e"; - -- /NO_MISSED_LABELS - -- - -- Do not insert missing end/exit labels. The end label is the name of - -- a construct that may optionally appear at the end of the construct. - -- This includes the names of packages and subprograms. - -- Similarly, the exit label is the name of a loop that may appear as the - -- argument of an exit statement within the loop. By default, GNAT PRETTY - -- inserts these end/exit labels when they are absent in the original - -- source. This qualifier /NO_MISSED_LABELS suppresses this insertion, - -- so that the formatted source reflects the original. - - S_Pretty_Notabs : aliased constant S := "/NOTABS " & - "-notabs"; - -- /NOTABS - -- - -- Replace all tabulations in comments with spaces. - - S_Pretty_Numbers : aliased constant S := "/NUMBER_CASING=" & - "AS_DECLARED " & - "-ntD " & - "LOWER_CASE " & - "-ntL " & - "UPPER_CASE " & - "-ntU " & - "MIXED_CASE " & - "-ntM"; - -- /NUMBER_CASING=name-option - -- - -- Specify the casing of named number names. If not specified, the casing - -- of these names is defined by the NAME_CASING option. 'name-option' - -- is one of: - -- - -- AS_DECLARED Names are cased as they appear in the declaration - -- in the source file. - -- - -- LOWER_CASE Names are in lower case. - -- - -- UPPER_CASE Names are in upper case. - -- - -- MIXED_CASE Names are in mixed case. - - S_Pretty_Output : aliased constant S := "/OUTPUT=@" & - "-o@"; - -- /OUTPUT=file - -- - -- Write the output to the specified file. If the file already exists, - -- an error is reported. - - S_Pretty_Override : aliased constant S := "/OVERRIDING_REPLACE " & - "-rf"; - -- /NOOVERRIDING_REPLACE (D) - -- /OVERRIDING_REPLACE - -- - -- Replace the argument source with the pretty-printed source and copy the - -- argument source into filename.NPP, overriding any existing file if - -- needed. - - S_Pretty_Pragma : aliased constant S := "/PRAGMA_CASING=" & - "MIXED_CASE " & - "-pM " & - "LOWER_CASE " & - "-pL " & - "UPPER_CASE " & - "-pU"; - -- /PRAGMA_CASING[=pragma-option] - -- - -- Set the case of pragma identifiers. The default is Mixed case. - -- pragma-option may be one of the following: - -- - -- MIXED_CASE (D) - -- LOWER_CASE - -- UPPER_CASE - - S_Pretty_Processes : aliased constant S := "/PROCESSES=#" & - "-j#"; - - -- /NOPROCESSES (D) - -- /PROCESSES=NNN - -- - -- Use NNN processes to carry out the tree creations (internal - -- representations of the argument sources). On a multiprocessor machine - -- this speeds up processing of big sets of argument sources. If NNN is 0, - -- then the maximum number of parallel tree creations is the number of - -- core processors on the platform. - - S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before any other processing to - -- set the building environment. - - S_Pretty_Replace : aliased constant S := "/REPLACE " & - "-r"; - -- /NOREPLACE (D) - -- /REPLACE - -- - -- Replace the argument source with the pretty-printed source and copy the - -- argument source into filename.NPP. If filename.NPP already exists, - -- report an error and exit. - - S_Pretty_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" & - "--RTS=|"; - -- /RUNTIME_SYSTEM=xxx - -- - -- Compile against an alternate runtime system named xxx or RTS-xxx. - - S_Pretty_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory[,...]) - -- - -- When looking for source files also look in directories specified. - - S_Pretty_Specific : aliased constant S := "/SPECIFIC_CASING " & - "-D-"; - -- /SPECIFIC_CASING - -- - -- Do not use the default dictionary file; instead, use the casing - -- defined by a qualifier /NAME_CASING and/or any explicit dictionary - -- file specified by a qualifier /DICTIONARY. - - S_Pretty_Standard : aliased constant S := "/STANDARD_OUTPUT " & - "-pipe"; - -- /NOSTANDARD_OUTPUT (D) - -- /STANDARD_OUTPUT - -- - -- Redirect the output to the standard output. - - S_Pretty_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Pretty_Time : aliased constant S := "/TIME " & - "-t"; - -- /NOTIME (D) - -- /TIME - -- - -- Print out execution time - - S_Pretty_Types : aliased constant S := "/TYPE_CASING=" & - "AS_DECLARED " & - "-ntD " & - "LOWER_CASE " & - "-ntL " & - "UPPER_CASE " & - "-ntU " & - "MIXED_CASE " & - "-ntM"; - -- /TYPE_CASING=name-option - -- - -- Specify the casing of subtype names (including first subtypes from - -- type declarations). If not specified, the casing of these names is - -- defined by the NAME_CASING option. 'name-option' is one of: - -- - -- AS_DECLARED Names are cased as they appear in the declaration - -- in the source file. - -- - -- LOWER_CASE Names are in lower case. - -- - -- UPPER_CASE Names are in upper case. - -- - -- MIXED_CASE Names are in mixed case. - - S_Pretty_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Verbose mode; GNAT PRETTY generates version information and then a - -- trace of the actions it takes to produce or obtain the ASIS tree. - - S_Pretty_Warnings : aliased constant S := "/WARNINGS " & - "-w"; - -- /NOWARNINGS (D) - -- /WARNINGS - -- - -- Issue a warning to the standard error stream if it is not possible - -- to provide the required layout in the result source. - -- By default such warnings are not activated. - - Pretty_Switches : aliased constant Switches := - (S_Pretty_Add 'Access, - S_Pretty_Align 'Access, - S_Pretty_All_Prjs 'Access, - S_Pretty_Attrib 'Access, - S_Pretty_Comments 'Access, - S_Pretty_Compact_Is 'Access, - S_Pretty_Config 'Access, - S_Pretty_Constr 'Access, - S_Pretty_Comind 'Access, - S_Pretty_Current 'Access, - S_Pretty_Dico 'Access, - S_Pretty_Eol 'Access, - S_Pretty_Ext 'Access, - S_Pretty_Encoding 'Access, - S_Pretty_Enums 'Access, - S_Pretty_Files 'Access, - S_Pretty_Follow 'Access, - S_Pretty_Forced 'Access, - S_Pretty_Formfeed 'Access, - S_Pretty_Indent 'Access, - S_Pretty_Keyword 'Access, - S_Pretty_Maxlen 'Access, - S_Pretty_Maxact 'Access, - S_Pretty_Maxind 'Access, - S_Pretty_Maxpar 'Access, - S_Pretty_Mess 'Access, - S_Pretty_Names 'Access, - S_Pretty_No_Labels 'Access, - S_Pretty_Notabs 'Access, - S_Pretty_Numbers 'Access, - S_Pretty_Output 'Access, - S_Pretty_Override 'Access, - S_Pretty_Pragma 'Access, - S_Pretty_Replace 'Access, - S_Pretty_Replace_No_Backup'Access, - S_Pretty_Processes 'Access, - S_Pretty_Project 'Access, - S_Pretty_RTS 'Access, - S_Pretty_Search 'Access, - S_Pretty_Sep_Label 'Access, - S_Pretty_Sep_Loop_Then 'Access, - S_Pretty_N_Sep_Loop_Then 'Access, - S_Pretty_Subdirs 'Access, - S_Pretty_Use_On_New_Line 'Access, - S_Pretty_Stnm_On_Nw_Line 'Access, - S_Pretty_Specific 'Access, - S_Pretty_Standard 'Access, - S_Pretty_Time 'Access, - S_Pretty_Types 'Access, - S_Pretty_Verbose 'Access, - S_Pretty_Warnings 'Access); - - ------------------------------ - -- Switches for GNAT SHARED -- - ------------------------------ - - S_Shared_Debug : aliased constant S := "/DEBUG=" & - "ALL " & - "-g3 " & - "NONE " & - "-g0 " & - "TRACEBACK " & - "-g1 " & - "NOTRACEBACK " & - "-g0"; - -- /DEBUG[=debug-option] - -- /NODEBUG - -- - -- Specifies the amount of debugging information included. 'debug-option' - -- is one of the following: - -- - -- ALL (D) Include full debugging information. - -- - -- NONE Provide no debugging information. Same as /NODEBUG. - -- - -- TRACEBACK Provide sufficient debug information for a traceback. - -- - -- NOTRACEBACK Same as NONE. - - S_Shared_Image : aliased constant S := "/IMAGE=@" & - "-o@"; - -- /IMAGE=image-name - -- - -- 'image-name' specifies the name for the generated shared library. - - S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' & - "--for-linker=IDENT=" & - '"'; - -- /IDENTIFICATION="" - -- - -- "" specifies the string to be stored in the image file ident- - -- ification field in the image header. It overrides any pragma Ident - -- specified string. - - S_Shared_NoInhib : aliased constant S := "/NOINHIBIT-IMAGE " & - "--for-linker=--noinhibit-exec"; - -- /NOINHIBIT-EXEC (D) - -- - -- Preserve image if there are warnings. This is the default. - - S_Shared_Inhib : aliased constant S := "/INHIBIT-IMAGE " & - "--for-linker=--inhibit-exec"; - -- /INHIBIT-EXEC - -- - -- Remove image if there are warnings. - - S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " & - "-nostartfiles"; - -- /NOSTART_FILES - -- - -- Link in default image initialization and startup functions. - - S_Shared_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Causes additional information to be output, including a full list of - -- the included object files. This switch option is most useful when you - -- want to see what set of object files are being used in the link step. - - S_Shared_ZZZZZ : aliased constant S := "/ " & - "--for-linker="; - -- / - -- - -- Any other switch transmitted to the underlying linker. - - Shared_Switches : aliased constant Switches := - (S_Shared_Debug 'Access, - S_Shared_Image 'Access, - S_Shared_Ident 'Access, - S_Shared_NoInhib 'Access, - S_Shared_Inhib 'Access, - S_Shared_Nofiles 'Access, - S_Shared_Verb 'Access, - S_Shared_ZZZZZ 'Access); - - ----------------------------- - -- Switches for GNAT STACK -- - ----------------------------- - - S_Stack_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Stack_All : aliased constant S := "/ALL_SUBPROGRAMS " & - "-a"; - -- /NOALL_SUBPROGRAMS (D) - -- /ALL_SUBPROGRAMS - -- - -- Consider all subprograms as entry points. - - S_Stack_All_Cycles : aliased constant S := "/ALL_CYCLES " & - "-ca"; - -- /NOALL_CYCLES (D) - -- /ALL_CYCLES - -- - -- Extract all possible cycles in the call graph. - - S_Stack_All_Prjs : aliased constant S := "/ALL_PROJECTS " & - "-U"; - -- /NOALL_PROJECTS (D) - -- /ALL_PROJECTS - -- - -- When GNAT STACK is used with a Project File and no source is - -- specified, the underlying tool gnatstack is called for all the - -- units of all the Project Files in the project tree. - - S_Stack_Debug : aliased constant S := "/DEBUG " & - "-g"; - -- /NODEBUG (D) - -- /DEBUG - -- - -- Generate internal debug information. - - S_Stack_Directory : aliased constant S := "/DIRECTORY=*" & - "-aO*"; - -- /DIRECTORY=(direc[,...]) - -- - -- When looking for .ci files look also in directories specified. - - S_Stack_Entries : aliased constant S := "/ENTRIES=*" & - "-e*"; - -- - -- /ENTRY=(entry_point[,...]) - -- - -- Name of symbol to be used as entry point for the analysis. - - S_Stack_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Stack_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Stack_Help : aliased constant S := "/HELP " & - "-h"; - -- /NOHELP (D) - -- /HELP - -- - -- Output a message explaining the usage of gnatstack. - - S_Stack_List : aliased constant S := "/LIST=#" & - "-l#"; - -- /LIST=nnn - -- - -- Print the nnn subprograms requiring the biggest local stack usage. By - -- default none will be displayed. - - S_Stack_Order : aliased constant S := "/ORDER=" & - "STACK " & - "-os " & - "ALPHABETICAL " & - "-oa"; - -- /ORDER[=order-option] - -- - -- Specifies the order for displaying the different call graphs. - -- order-option may be one of the following: - -- - -- STACK (D) Select stack usage order - -- - -- ALPHABETICAL Select alphabetical order - - S_Stack_Path : aliased constant S := "/PATH " & - "-p"; - -- /NOPATH (D) - -- /PATH - -- - -- Print all the subprograms that make up the worst-case path for every - -- entry point. - - S_Stack_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of - -- gnatstack. - - S_Stack_Output : aliased constant S := "/OUTPUT=@" & - "-f@"; - -- /OUTPUT=filename - -- - -- Name of the file containing the generated graph (VCG format). - - S_Stack_Regexp : aliased constant S := "/EXPRESSION=|" & - "-r|"; - -- - -- /EXPRESSION=regular-expression - -- - -- Any symbol matching the regular expression will be considered as a - -- potential entry point for the analysis. - - S_Stack_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Stack_Unbounded : aliased constant S := "/UNBOUNDED=#" & - "-d#"; - -- /UNBOUNDED=nnn - -- - -- Default stack size to be used for unbounded (dynamic) frames. - - S_Stack_Unknown : aliased constant S := "/UNKNOWN=#" & - "-u#"; - -- /UNKNOWN=nnn - -- - -- Default stack size to be used for unknown (external) calls. - - S_Stack_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Specifies the amount of information to be displayed about the - -- different subprograms. In verbose mode the full location of the - -- subprogram will be part of the output, as well as detailed information - -- about inaccurate data. - - S_Stack_Warnings : aliased constant S := "/WARNINGS=" & - "ALL " & - "-Wa " & - "CYCLES " & - "-Wc " & - "UNBOUNDED " & - "-Wu " & - "EXTERNAL " & - "-We " & - "INDIRECT " & - "-Wi"; - -- /WARNINGS[=(keyword[,...])] - -- - -- The following keywords are supported: - -- - -- ALL Turn on all optional warnings - -- - -- CYCLES Turn on warnings for cycles - -- - -- UNBOUNDED Turn on warnings for unbounded frames - -- - -- EXTERNAL Turn on warnings for external calls - -- - -- INDIRECT Turn on warnings for indirect calls - - Stack_Switches : aliased constant Switches := - (S_Stack_Add 'Access, - S_Stack_All 'Access, - S_Stack_All_Cycles 'Access, - S_Stack_All_Prjs 'Access, - S_Stack_Debug 'Access, - S_Stack_Directory 'Access, - S_Stack_Entries 'Access, - S_Stack_Files 'Access, - S_Stack_Follow 'Access, - S_Stack_Help 'Access, - S_Stack_List 'Access, - S_Stack_Order 'Access, - S_Stack_Path 'Access, - S_Stack_Project 'Access, - S_Stack_Output 'Access, - S_Stack_Regexp 'Access, - S_Stack_Subdirs 'Access, - S_Stack_Unbounded 'Access, - S_Stack_Unknown 'Access, - S_Stack_Verbose 'Access, - S_Stack_Warnings 'Access); - - ---------------------------- - -- Switches for GNAT STUB -- - ---------------------------- - - S_Stub_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Stub_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" & - "-gnatec>"; - -- /CONFIGURATION_PRAGMAS_FILE=filespec - -- - -- Specifies a configuration pragmas file that must be taken into account - -- when compiling. - - S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " & - "!-I-"; - -- /CURRENT_DIRECTORY (D) - -- /NOCURRENT_DIRECTORY - -- - -- Look for source, library or object files in the default directory. - - S_Stub_Encoding : aliased constant S := "/RESULT_ENCODING=" & - "BRACKETS " & - "-Wb " & - "HEX " & - "-Wh " & - "UPPER " & - "-Wu " & - "SHIFT_JIS " & - "-Ws " & - "EUC " & - "-We " & - "UTF8 " & - "-W8"; - -- /RESULT_ENCODING[=encoding-type] - -- - -- Specify the wide character encoding method used when writing the - -- generated body in the result file. 'encoding-type' is one of the - -- following: - -- - -- BRACKETS (D) Brackets encoding. - -- - -- HEX Hex ESC encoding. - -- - -- UPPER Upper half encoding. - -- - -- SHIFT_JIS Shift-JIS encoding. - -- - -- EUC EUC Encoding. - -- - -- UTF8 UTF-8 encoding. - -- - -- See 'HELP GNAT COMPILE /WIDE_CHARACTER_ENCODING' for an explanation - -- about the different character encoding methods. - - S_Stub_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Stub_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Stub_Full : aliased constant S := "/FULL " & - "-f"; - -- /NOFULL (D) - -- /FULL - -- - -- If the destination directory already contains a file with the name of - -- the body file for the argument file spec, replace it with the generated - -- body stub. If /FULL is not used and there is already a body file, this - -- existing body file is not replaced. - - S_Stub_Header : aliased constant S := "/HEADER=" & - "GENERAL " & - "-hg " & - "SPEC " & - "-hs"; - -- /HEADER[=header-option] - -- - -- Specifies the form of the comment header above the generated body stub. - -- If no /HEADER qualifier is specified, there is no comment header. - -- header-option is one of the following: - -- - -- - -- GENERAL (D) Put a sample comment header into the body stub. - -- - -- SPEC Put the comment header (i.e., all the comments - -- preceding the compilation unit) from the source of the - -- library unit declaration into the body stub. - - S_Stub_Header_File : aliased constant S := "/FROM_HEADER_FILE=<" & - "--header-file=>"; - - -- /FROM_HEADER_FILE==filename - -- - -- Use the content of the file as the comment header for a generated body - -- stub. - - S_Stub_Indent : aliased constant S := "/INDENTATION=#" & - "-i#"; - -- /INDENTATION=nnn - -- - -- (nnn is a non-negative integer). Set the indentation level in the - -- generated body stub to nnn. nnn=0 means "no indentation". - -- Default indentation is 3. - - S_Stub_Keep : aliased constant S := "/KEEP " & - "-k"; - -- /NOKEEP (D) - -- /KEEP - -- - -- Do not delete the tree file (i.e., the snapshot of the compiler - -- internal structures used by gnatstub) after creating the body stub. - - S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" & - "-l#"; - -- /LINE_LENGTH=nnn - -- - -- (n is a non-negative integer). Set the maximum line length in the body - -- stub to nnn. Default is 78. - - S_Stub_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Stub_No_Exc : aliased constant S := "/NO_EXCEPTION " & - "--no-exception"; - -- /NONO_EXCEPTION (D) - -- /NO_EXCEPTION - -- - -- Avoid raising PROGRAM_ERROR in the generated program unit stubs. - - S_Stub_No_Head : aliased constant S := "/NO_LOCAL_HEADER " & - "--no-local-header"; - -- /NONO_LOCAL_HEADER (D) - -- /NO_LOCAL_HEADER - -- - -- Do not put local comment header before body stub for local program unit. - - S_Stub_Output : aliased constant S := "/OUTPUT=@" & - "-o@"; - -- /OUTPUT=filespec - -- - -- Body file name. This should be set if the argument file name does not - -- follow the GNAT file naming conventions. If this switch is omitted, - -- the default name for the body will be obtained from the argument file - -- name according to the GNAT file naming conventions. - - S_Stub_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before any other processing. - -- The source and object directories to be searched will be communicated - -- to gnatstub through logical names ADA_PRJ_INCLUDE_FILE and - -- ADA_PRJ_OBJECTS_FILE. - - S_Stub_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Quiet mode: do not generate a confirmation when a body is successfully - -- created, and do not generate a message when a body is not required for - -- an argument unit. - - S_Stub_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory[,...]) - -- - -- When looking for source files also look in directories specified. - - S_Stub_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Stub_Tree : aliased constant S := "/TREE_FILE=" & - "OVERWRITE " & - "-t " & - "SAVE " & - "-k " & - "REUSE " & - "-r"; - -- /TREE_FILE[=treefile-option] - -- - -- Specify what to do with the tree file. - -- treefile-option is one of the following: - -- - -- OVERWRITE (D) Overwrite the existing tree file. If the current - -- directory already contains the file which, according - -- to the GNAT file naming rules should be considered - -- as a tree file for the argument source file, gnatstub - -- will refuse to create the tree file needed to create - -- a sample body unless this option is chosen. - -- - -- SAVE Do not remove the tree file (i.e., the snapshot - -- of the compiler internal structures used by gnatstub) - -- after creating the body stub. - -- - -- REUSE Reuse the tree file (if it exists) instead of - -- creating it. - -- Instead of creating the tree file for the library - -- unit declaration, gnatstub tries to find it in the - -- current directory and use it for creating a body. - -- If the tree file is not found, no body is created. - -- This option also implies `SAVE', whether or not the - -- latter is set explicitly. - - S_Stub_Verbose : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- Verbose mode: generate version information. - - Stub_Switches : aliased constant Switches := - (S_Stub_Add 'Access, - S_Stub_Config 'Access, - S_Stub_Current 'Access, - S_Stub_Encoding 'Access, - S_Stub_Ext 'Access, - S_Stub_Follow 'Access, - S_Stub_Full 'Access, - S_Stub_Header 'Access, - S_Stub_Header_File'Access, - S_Stub_Indent 'Access, - S_Stub_Keep 'Access, - S_Stub_Length 'Access, - S_Stub_Mess 'Access, - S_Stub_Output 'Access, - S_Stub_Project 'Access, - S_Stub_No_Exc 'Access, - S_Stub_No_Head 'Access, - S_Stub_Quiet 'Access, - S_Stub_Search 'Access, - S_Stub_Subdirs 'Access, - S_Stub_Tree 'Access, - S_Stub_Verbose 'Access); - - ---------------------------- - -- Switches for GNAT SYNC -- - ---------------------------- - - S_Sync_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Sync_All : aliased constant S := "/ALL " & - "-a"; - -- /NOALL (D) - -- /ALL - -- - -- Also check the components of the GNAT run time and process the needed - -- components of the GNAT RTL when building and analyzing the global - -- structure for checking the global rules. - - S_Sync_Allproj : aliased constant S := "/ALL_PROJECTS " & - "-U"; - -- /NOALL_PROJECTS (D) - -- /ALL_PROJECTS - -- - -- When GNAT SYNC is used with a Project File and no source is - -- specified, the underlying tool gnatsync is called for all the - -- sources of all the Project Files in the project tree. - - S_Sync_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Sync_Files : aliased constant S := "/FILES=@" & - "-files=@"; - -- /FILES=filename - -- - -- Take as arguments the files that are listed in the specified - -- text file. - - S_Sync_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Sync_Main : aliased constant S := "/MAIN_SUBPROGRAM=@" & - "-main=@"; - -- /MAIN_SUBPROGRAM=filename - -- - -- Specify the name of the file containing the main subprogram - - S_Sync_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Sync_Project : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before the invocation of the - -- gnatcheck. The source directories to be searched will be communicated - -- to gnatcheck through logical name ADA_PRJ_INCLUDE_FILE. - - S_Sync_Quiet : aliased constant S := "/QUIET " & - "-q"; - -- /NOQUIET (D) - -- /QUIET - -- - -- Work quietly, only output warnings and errors. - - S_Sync_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Sync_Verb : aliased constant S := "/VERBOSE " & - "-v"; - -- /NOVERBOSE (D) - -- /VERBOSE - -- - -- The version number and copyright notice are output, as well as exact - -- copies of the gnat1 commands spawned to obtain the chop control - -- information. - - S_Sync_Exec : aliased constant S := "/EXECUTION_TIME " & - "-t"; - -- /NOEXECUTION_TIME (D) - -- /EXECUTION_TIME - -- - -- Output the execution time - - S_Sync_Details : aliased constant S := "/DETAILS=" & - "MEDIUM " & - "-om " & - "SHORT " & - "-os " & - "FULL " & - "-of"; - -- /DETAILS[=options] - -- - -- Specifies the details of the output. - -- Options may be one of the following: - -- - -- MEDIUM (D) - -- SHORT - -- FULL - - S_Sync_Warnoff : aliased constant S := "/WARNINGS_OFF " & - "-wq"; - -- - -- /WARNINGS_OFF - -- - -- Turn warnings off - - S_Sync_Output : aliased constant S := "/OUTPUT_FILE=<" & - "-out_file=>"; - -- - -- /OUTPUT_FILE=filename - -- - -- Redirect output to a text file - - Sync_Switches : aliased constant Switches := - (S_Sync_Add 'Access, - S_Sync_All 'Access, - S_Sync_Allproj 'Access, - S_Sync_Ext 'Access, - S_Sync_Follow 'Access, - S_Sync_Files 'Access, - S_Sync_Main 'Access, - S_Sync_Mess 'Access, - S_Sync_Project 'Access, - S_Sync_Quiet 'Access, - S_Sync_Subdirs 'Access, - S_Sync_Verb 'Access, - S_Sync_Exec 'Access, - S_Sync_Details 'Access, - S_Sync_Warnoff 'Access, - S_Sync_Output 'Access); - - ---------------------------- - -- Switches for GNAT TEST -- - ---------------------------- - - Test_Switches : aliased constant Switches := - (1 .. 0 => null); - - ---------------------------- - -- Switches for GNAT XREF -- - ---------------------------- - - S_Xref_Add : aliased constant S := "/ADD_PROJECT_SEARCH_DIR=*" & - "-aP*"; - -- /ADD_PROJECT_SEARCH_PATH=(directory[,...]) - -- - -- Add directories to the project search path. - - S_Xref_All : aliased constant S := "/ALL_FILES " & - "-a"; - -- /NOALL_FILES (D) - -- /ALL_FILES - -- - -- If this switch is present, FIND and XREF will parse the read-only - -- files found in the library search path. Otherwise, these files will - -- be ignored. This option can be used to protect Gnat sources or your - -- own libraries from being parsed, thus making FIND and XREF much - -- faster, and their output much smaller. - - S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " & - "-d"; - -- /NODERIVED_TYPES (D) - -- /DERIVED_TYPES - -- - -- Output the parent type reference for each matching derived types. - - S_Xref_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' & - "-X" & '"'; - -- /EXTERNAL_REFERENCE="name=val" - -- - -- Specifies an external reference to the project manager. Useful only if - -- /PROJECT_FILE is used. - -- - -- Example: - -- /EXTERNAL_REFERENCE="DEBUG=TRUE" - - S_Xref_Follow : aliased constant S := "/FOLLOW_LINKS_FOR_FILES " & - "-eL"; - -- /NOFOLLOW_LINKS_FOR_FILES (D) - -- /FOLLOW_LINKS_FOR_FILES - -- - -- Follow links when parsing project files - - S_Xref_Full : aliased constant S := "/FULL_PATHNAME " & - "-f"; - -- /NOFULL_PATHNAME (D) - -- /FULL_PATHNAME - -- - -- If this switch is set, the output file names will be preceded by their - -- directory (if the file was found in the search path). If this switch - -- is not set, the directory will not be printed. - - S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " & - "-g"; - -- /NOIGNORE_LOCALS (D) - -- /IGNORE_LOCALS - -- - -- If this switch is set, information is output only for library-level - -- entities, ignoring local entities. The use of this switch may - -- accelerate FIND and XREF. - - S_Xref_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" & - "DEFAULT " & - "-vP0 " & - "MEDIUM " & - "-vP1 " & - "HIGH " & - "-vP2"; - -- /MESSAGES_PROJECT_FILE[=messages-option] - -- - -- Specifies the "verbosity" of the parsing of project files. - -- messages-option may be one of the following: - -- - -- DEFAULT (D) No messages are output if there is no error or warning. - -- - -- MEDIUM A small number of messages are output. - -- - -- HIGH A great number of messages are output, most of them not - -- being useful for the user. - - S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " & - "-nostdinc"; - -- /NOSTD_INCLUDES - -- - -- Do not look for sources in the system default directory. - - S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " & - "-nostdlib"; - -- /NOSTD_LIBRARIES - -- - -- Do not look for library files in the system default directory. - - S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" & - "-aO*"; - -- /OBJECT_SEARCH=(directory,...) - -- - -- When searching for library and object files, look in the specified - -- directories. The order in which library files are searched is the same - -- as for MAKE. - - S_Xref_Project : aliased constant S := "/PROJECT=@" & - "-p@"; - -- /PROJECT=file - -- - -- Specify a project file to use. By default, FIND and XREF will try to - -- locate a project file in the current directory. - -- - -- If a project file is either specified or found by the tools, then the - -- content of the source directory and object directory lines are added - -- as if they had been specified respectively by /SOURCE_SEARCH and - -- /OBJECT_SEARCH. - - S_Xref_Prj : aliased constant S := "/PROJECT_FILE=<" & - "-P>"; - -- /PROJECT_FILE=filename - -- - -- Specifies the main project file to be used. The project files rooted - -- at the main project file will be parsed before doing any processing. - -- The source and object directories to be searched will be communicated - -- to gnatxref through logical names ADA_PRJ_INCLUDE_FILE and - -- ADA_PRJ_OBJECTS_FILE. - - S_Xref_Search : aliased constant S := "/SEARCH=*" & - "-I*"; - -- /SEARCH=(directory,...) - -- - -- Equivalent to: - -- /OBJECT_SEARCH=(directory,...) /SOURCE_SEARCH=(directory,...) - - S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" & - "-aI*"; - -- /SOURCE_SEARCH=(directory,...) - -- - -- When looking for source files also look in the specified directories. - -- The order in which source file search is undertaken is the same as for - -- MAKE. - - S_Xref_Subdirs : aliased constant S := "/SUBDIRS=<" & - "--subdirs=>"; - -- /SUBDIRS=dir - -- - -- The actual directories (object, exec, library, ...) are subdirectories - -- of the directory specified in the project file. If the subdirectory - -- does not exist, it is created automatically. - - S_Xref_Output : aliased constant S := "/UNUSED " & - "-u"; - -- /SOURCE_SEARCH=(directory,...) - -- - -- When looking for source files also look in the specified directories. - -- The order in which source file search is undertaken is the same as for - -- MAKE. - - S_Xref_Tags : aliased constant S := "/TAGS " & - "-v"; - -- /NOTAGS (D) - -- /TAGS - -- - -- Print a 'tags' file for vi. - - Xref_Switches : aliased constant Switches := - (S_Xref_Add 'Access, - S_Xref_All 'Access, - S_Xref_Deriv 'Access, - S_Xref_Ext 'Access, - S_Xref_Follow 'Access, - S_Xref_Full 'Access, - S_Xref_Global 'Access, - S_Xref_Mess 'Access, - S_Xref_Nostinc 'Access, - S_Xref_Nostlib 'Access, - S_Xref_Object 'Access, - S_Xref_Project 'Access, - S_Xref_Prj 'Access, - S_Xref_Search 'Access, - S_Xref_Source 'Access, - S_Xref_Subdirs 'Access, - S_Xref_Output 'Access, - S_Xref_Tags 'Access); - -end VMS_Data; diff --git a/main/gcc/ada/vxaddr2line.adb b/main/gcc/ada/vxaddr2line.adb index b65ebc6acd6..edcc95cc07f 100644 --- a/main/gcc/ada/vxaddr2line.adb +++ b/main/gcc/ada/vxaddr2line.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2013, AdaCore -- +-- Copyright (C) 2002-2014, 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,18 +41,18 @@ -- selects the target architecture. In the absence of this parameter the -- default variant is chosen based on the Detect_Arch result. Generally, -- this parameter will only be used if vxaddr2line is recompiled manually. --- Otherwise, the command name will always be of the form --- -vxaddr2line where there is no ambiguity on the target's --- architecture. +-- Otherwise, the command name will always be of the form: +-- -vxaddr2line +-- where there is no ambiguity on the target's architecture. -- : -- The name of the partially linked binary file for the application. -- : --- Runtime address (on the target) of a reference symbol you choose, --- which name shall match the value of the Ref_Symbol variable declared --- below. A symbol with a small offset from the beginning of the text --- segment is better, so "adainit" is a good choice. +-- Runtime address (on the target) of a reference symbol you choose. This +-- name must match the value of the Ref_Symbol variable declared below. +-- A symbol with a small offset from the beginning of the text segment is +-- better, so "adainit" is a good choice. -- : -- The call chain addresses you obtained at run time on the target and @@ -78,7 +78,7 @@ procedure VxAddr2Line is -- Instantiate Modular_IO to have Put Ref_Symbol : constant String := "adainit"; - -- This is the name of the reference symbol which runtime address shall + -- This is the name of the reference symbol whose runtime address must -- be provided as the argument. -- All supported architectures diff --git a/main/gcc/ada/vxworks-crtbe-link.spec b/main/gcc/ada/vxworks-crtbe-link.spec new file mode 100644 index 00000000000..8c4398d4770 --- /dev/null +++ b/main/gcc/ada/vxworks-crtbe-link.spec @@ -0,0 +1,13 @@ +*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/main/gcc/ada/vxworks-ppc-link.spec b/main/gcc/ada/vxworks-ppc-link.spec new file mode 100644 index 00000000000..8f6263cf42e --- /dev/null +++ b/main/gcc/ada/vxworks-ppc-link.spec @@ -0,0 +1,6 @@ +*lib: ++ %{mrtp:%{!shared: \ + -L%:if-exists-else( \ + %:getenv(WIND_BASE /target/lib/usr/lib/ppc/PPC32/common) \ + %:getenv(WIND_BASE /target/usr/lib/ppc/PPC32/common)) \ + }} diff --git a/main/gcc/ada/warnsw.adb b/main/gcc/ada/warnsw.adb index 36ae4219415..10b60a8f779 100644 --- a/main/gcc/ada/warnsw.adb +++ b/main/gcc/ada/warnsw.adb @@ -636,7 +636,6 @@ package body Warnsw is else return False; end if; - return False; end case; return True; @@ -648,35 +647,36 @@ package body Warnsw is procedure WA_Warnings is begin - Check_Unreferenced := True; - Check_Unreferenced_Formals := True; - Check_Withs := True; - Constant_Condition_Warnings := True; - Implementation_Unit_Warnings := True; - Ineffective_Inline_Warnings := True; - Warn_On_Ada_2005_Compatibility := True; - Warn_On_Ada_2012_Compatibility := True; - Warn_On_Assertion_Failure := True; - Warn_On_Assumed_Low_Bound := True; - Warn_On_Bad_Fixed_Value := True; - Warn_On_Biased_Representation := True; - Warn_On_Constant := True; - Warn_On_Export_Import := True; - Warn_On_Modified_Unread := True; - Warn_On_No_Value_Assigned := True; - Warn_On_Non_Local_Exception := True; - Warn_On_Object_Renames_Function := True; - Warn_On_Obsolescent_Feature := True; - Warn_On_Overlap := True; - Warn_On_Parameter_Order := True; - Warn_On_Questionable_Missing_Parens := True; - Warn_On_Redundant_Constructs := True; - Warn_On_Reverse_Bit_Order := True; - Warn_On_Size_Alignment := True; - Warn_On_Suspicious_Contract := True; - Warn_On_Unchecked_Conversion := True; - Warn_On_Unrecognized_Pragma := True; - Warn_On_Unrepped_Components := True; + Check_Unreferenced := True; -- -gnatwf/-gnatwu + Check_Unreferenced_Formals := True; -- -gnatwf/-gnatwu + Check_Withs := True; -- -gnatwu + Constant_Condition_Warnings := True; -- -gnatwc + Implementation_Unit_Warnings := True; -- -gnatwi + Ineffective_Inline_Warnings := True; -- -gnatwp + Warn_On_Ada_2005_Compatibility := True; -- -gnatwy + Warn_On_Ada_2012_Compatibility := True; -- -gnatwy + 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_Constant := True; -- -gnatwk + Warn_On_Export_Import := True; -- -gnatwx + Warn_On_Modified_Unread := True; -- -gnatwm + Warn_On_No_Value_Assigned := True; -- -gnatwv + Warn_On_Non_Local_Exception := True; -- -gnatw.x + Warn_On_Object_Renames_Function := True; -- -gnatw.r + Warn_On_Obsolescent_Feature := True; -- -gnatwj + 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_Reverse_Bit_Order := True; -- -gnatw.v + Warn_On_Size_Alignment := True; -- -gnatw.z + Warn_On_Suspicious_Contract := True; -- -gnatw.t + Warn_On_Suspicious_Modulus_Value := True; -- -gnatw.m + Warn_On_Unchecked_Conversion := True; -- -gnatwz + Warn_On_Unrecognized_Pragma := True; -- -gnatwg + Warn_On_Unrepped_Components := True; -- -gnatw.c end WA_Warnings; end Warnsw; diff --git a/main/gcc/ada/widechar.ads b/main/gcc/ada/widechar.ads index 7db577adda1..a6e8293ae5d 100644 --- a/main/gcc/ada/widechar.ads +++ b/main/gcc/ada/widechar.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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/main/gcc/ada/xgnatugn.adb b/main/gcc/ada/xgnatugn.adb deleted file mode 100644 index 4706701e9b1..00000000000 --- a/main/gcc/ada/xgnatugn.adb +++ /dev/null @@ -1,1086 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT SYSTEM UTILITIES -- --- -- --- X G N A T U G N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is 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 utility is used to process the source of gnat_ugn.texi to make a --- version suitable for running through standard Texinfo processor. It is --- invoked as follows: - --- xgnatugn [ [ ] ] - --- 1. is the target type of the manual, which is one of: - --- unw Unix and Windows platforms --- vms OpenVMS - --- 2. is the file name of the Texinfo file to be --- preprocessed. - --- 3. is the name of the word list file. This file is used for --- rewriting the VMS edition. Each line contains a word mapping: The source --- word in the first column, the target word in the second column. The --- columns are separated by a '^' character. When preprocessing for VMS, the --- first word is replaced with the second. (Words consist of letters, --- digits, and the four characters "?-_~". A sequence of multiple words can --- be replaced if they are listed in the first column, separated by a single --- space character. If multiple words are to be replaced, there must be a --- replacement for each prefix.) - --- 4. (optional) is the name of the output file. It defaults to --- gnat_ugn_unw.texi or gnat_ugn_vms.texi, depending on the target. - --- 5. (optional, and allowed only if is explicit) --- can be any string. If present, it indicates that warning messages are --- to be output to Standard_Error. If absent, no warning messages are --- generated. - --- The following steps are performed: - --- In VMS mode - --- Any occurrences of ^alpha^beta^ are replaced by beta. The sequence --- must fit on a single line, and there can only be one occurrence on a --- line. - --- Any occurrences of a word in the Ug_Words list are replaced by the --- appropriate vms equivalents. Note that replacements do not occur --- within ^alpha^beta^ sequences. - --- Any occurrence of [filename].extension, where extension one of the --- following: - --- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c" - --- replaced by the appropriate VMS names (all upper case with .o --- replaced .OBJ). Note that replacements do not occur within --- ^alpha^beta^ sequences. - --- In UNW mode - --- Any occurrences of ^alpha^beta^ are replaced by alpha. The sequence --- must fit on a single line. - --- In both modes - --- The sequence ^^^ is replaced by a single ^. This escape sequence --- must be used if the literal character ^ is to appear in the --- output. A line containing this escape sequence may not also contain --- a ^alpha^beta^ sequence. - -with Ada.Command_Line; use Ada.Command_Line; -with Ada.Strings; use Ada.Strings; -with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; -with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; -with Ada.Text_IO; use Ada.Text_IO; - -with GNAT.Spitbol; use GNAT.Spitbol; -with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString; - -procedure Xgnatugn is - - procedure Usage; - -- Print usage information. Invoked if an invalid command line is - -- encountered. - - subtype Sfile is Ada.Streams.Stream_IO.File_Type; - - Output_File : Sfile; - -- The preprocessed output is written to this file - - type Input_File is record - Name : VString; - Data : Ada.Text_IO.File_Type; - Line : Natural := 0; - end record; - -- Records information on an input file. Name and Line are used - -- in error messages, Line is updated automatically by Get_Line. - - function Get_Line (Input : access Input_File) return String; - -- Returns a line from Input and performs the necessary - -- line-oriented checks (length, character set, trailing spaces). - - procedure Put_Line (F : Sfile; S : String); - -- Local version of Put_Line ensures Unix style line endings - - First_Time : Boolean := True; - Number_Of_Warnings : Natural := 0; - Number_Of_Errors : Natural := 0; - Warnings_Enabled : Boolean; - - procedure Error - (Input : Input_File; - At_Character : Natural; - Message : String); - procedure Error - (Input : Input_File; - Message : String); - -- Prints a message reporting an error on line Input.Line. If - -- At_Character is not 0, indicate the exact character at which - -- the error occurs. - - procedure Warning - (Input : Input_File; - At_Character : Natural; - Message : String); - - Dictionary_File : aliased Input_File; - procedure Read_Dictionary_File; - -- Dictionary_File is opened using the name given on the command - -- line. It contains the replacements for the Ug_Words list. - -- Read_Dictionary_File reads Dictionary_File and fills the - -- Ug_Words table. - - Source_File : aliased Input_File; - procedure Process_Source_File; - -- Source_File is opened using the name given on the command line. - -- It contains the Texinfo source code. Process_Source_File - -- performs the necessary replacements. - - type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, GPLEDITION); - -- The flags permitted in @ifset or @ifclear commands: - -- - -- Targets for preprocessing - -- UNW (Unix and Windows) or VMS - -- - -- Editions of the manual - -- FSFEDITION, PROEDITION, or GPLEDITION - -- - -- Conditional commands for target are processed by xgnatugn - -- - -- Conditional commands for edition are passed through unchanged - - subtype Target_Type is Flag_Type range UNW .. VMS; - - Target : Target_Type; - -- The Target variable is initialized using the command line - - Valid_Characters : constant Character_Set := To_Set (Span => (' ', '~')); - -- This array controls which characters are permitted in the input - -- file (after line breaks have been removed). Valid characters - -- are all printable ASCII characters and the space character. - - Word_Characters : constant Character_Set := - (To_Set (Ranges => - (('0', '9'), ('a', 'z'), ('A', 'Z'))) - or To_Set ("?-_~")); - -- The characters which are permitted in words. Other (valid) - -- characters are assumed to be delimiters between words. Note that - -- this set has to include all characters of the source words of the - -- Ug_Words dictionary. - - Reject_Trailing_Spaces : constant Boolean := True; - -- Controls whether Xgnatug rejects superfluous space characters - -- at the end of lines. - - Maximum_Line_Length : constant Positive := 79; - Fatal_Line_Length_Limit : constant Positive := 5000; - Fatal_Line_Length : exception; - -- If Maximum_Line_Length is exceeded in an input file, an error - -- message is printed. If Fatal_Line_Length is exceeded, - -- execution terminates with a Fatal_Line_Length exception. - - VMS_Escape_Character : constant Character := '^'; - -- The character used to mark VMS alternatives (^alpha^beta^) - - Extensions : GNAT.Spitbol.Table_VString.Table (20); - procedure Initialize_Extensions; - -- This table records extensions and their replacement for - -- rewriting filenames in the VMS version of the manual. - - function Is_Extension (Extension : String) return Boolean; - function Get_Replacement_Extension (Extension : String) return String; - -- These functions query the replacement table. Is_Extension - -- checks if the given string is a known extension. - -- Get_Replacement returns the replacement extension. - - Ug_Words : GNAT.Spitbol.Table_VString.Table (200); - function Is_Known_Word (Word : String) return Boolean; - function Get_Replacement_Word (Word : String) return String; - -- The Ug_Words table lists replacement words for the VMS version - -- of the manual. Is_Known_Word and Get_Replacement_Word query - -- this table. The table is filled using Read_Dictionary_File. - - function Rewrite_Source_Line (Line : String) return String; - -- This subprogram takes a line and rewrites it according to Target. - -- It relies on information in Source_File to generate error messages. - - ----------- - -- Usage -- - ----------- - - procedure Usage is - begin - Put_Line (Standard_Error, - "usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]"); - New_Line; - Put_Line (Standard_Error, "TARGET is one of:"); - - for T in Target_Type'Range loop - Put_Line (Standard_Error, " " & Target_Type'Image (T)); - end loop; - - New_Line; - Put_Line (Standard_Error, "SOURCE is the source file to process."); - New_Line; - Put_Line (Standard_Error, "DICTIONARY is the name of a file " - & "that contains word replacements"); - Put_Line (Standard_Error, "for the VMS version."); - New_Line; - Put_Line (Standard_Error, - "OUT-FILE, if present, is the output file to be created;"); - Put_Line (Standard_Error, - "If OUT-FILE is absent, the output file is either " & - "gnat_ugn_unw.texi, "); - Put_Line (Standard_Error, - "or gnat_ugn_vms.texi, depending on TARGET."); - New_Line; - Put_Line (Standard_Error, - "WARNINGS, if present, is any string;"); - Put_Line (Standard_Error, - "it will result in warning messages (e.g., line too long))"); - Put_Line (Standard_Error, - "being output to Standard_Error."); - end Usage; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line (Input : access Input_File) return String is - Line_Buffer : String (1 .. Fatal_Line_Length_Limit); - Last : Natural; - - begin - Input.Line := Input.Line + 1; - Get_Line (Input.Data, Line_Buffer, Last); - - if Last = Line_Buffer'Last then - Error (Input.all, "line exceeds fatal line length limit"); - raise Fatal_Line_Length; - end if; - - declare - Line : String renames Line_Buffer (Line_Buffer'First .. Last); - - begin - for J in Line'Range loop - if not Is_In (Line (J), Valid_Characters) then - Error (Input.all, J, "invalid character"); - exit; - end if; - end loop; - - if Line'Length > Maximum_Line_Length then - Warning (Input.all, Maximum_Line_Length + 1, "line too long"); - end if; - - if Reject_Trailing_Spaces - and then Line'Length > 0 - and then Line (Line'Last) = ' ' - then - Error (Input.all, Line'Last, "trailing space character"); - end if; - - return Trim (Line, Right); - end; - end Get_Line; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (F : Sfile; S : String) is - begin - String'Write (Stream (F), S); - Character'Write (Stream (F), ASCII.LF); - end Put_Line; - - ----------- - -- Error -- - ----------- - - procedure Error - (Input : Input_File; - Message : String) - is - begin - Error (Input, 0, Message); - end Error; - - procedure Error - (Input : Input_File; - At_Character : Natural; - Message : String) - is - Line_Image : constant String := Integer'Image (Input.Line); - At_Character_Image : constant String := Integer'Image (At_Character); - -- These variables are required because we have to drop the leading - -- space character. - - begin - Number_Of_Errors := Number_Of_Errors + 1; - - if At_Character > 0 then - Put_Line (Standard_Error, - S (Input.Name) & ':' - & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':' - & At_Character_Image (At_Character_Image'First + 1 - .. At_Character_Image'Last) - & ": " - & Message); - else - Put_Line (Standard_Error, - S (Input.Name) & ':' - & Line_Image (Line_Image'First + 1 .. Line_Image'Last) - & ": " - & Message); - end if; - end Error; - - ------------- - -- Warning -- - ------------- - - procedure Warning - (Input : Input_File; - At_Character : Natural; - Message : String) - is - Line_Image : constant String := Integer'Image (Input.Line); - At_Character_Image : constant String := Integer'Image (At_Character); - -- These variables are required because we have to drop the leading - -- space character. - - begin - if not Warnings_Enabled then - return; - end if; - - Number_Of_Warnings := Number_Of_Warnings + 1; - - if At_Character > 0 then - Put_Line (Standard_Error, - S (Input.Name) & ':' - & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':' - & At_Character_Image (At_Character_Image'First + 1 - .. At_Character_Image'Last) - & ": warning: " - & Message); - else - Put_Line (Standard_Error, - S (Input.Name) & ':' - & Line_Image (Line_Image'First + 1 .. Line_Image'Last) - & ": warning: " - & Message); - end if; - end Warning; - - -------------------------- - -- Read_Dictionary_File -- - -------------------------- - - procedure Read_Dictionary_File is - begin - while not End_Of_File (Dictionary_File.Data) loop - declare - Line : constant String := - Get_Line (Dictionary_File'Access); - Split : constant Natural := - Index (Line, (1 => VMS_Escape_Character)); - - begin - if Line'Length = 0 then - Error (Dictionary_File, "empty line in dictionary file"); - - elsif Line (Line'First) = ' ' then - Error (Dictionary_File, 1, "line starts with space character"); - - elsif Split = 0 then - Error (Dictionary_File, "line does not contain " - & VMS_Escape_Character & " character"); - else - declare - Source : constant String := - Trim (Line (1 .. Split - 1), Both); - Target : constant String := - Trim (Line (Split + 1 .. Line'Last), Both); - - Two_Spaces : constant Natural := Index (Source, " "); - - Non_Word_Character : constant Natural := - Index (Source, - Word_Characters or - To_Set (" ."), - Outside); - - begin - if Two_Spaces /= 0 then - Error (Dictionary_File, Two_Spaces, - "multiple space characters in source word"); - end if; - - if Non_Word_Character /= 0 then - Error (Dictionary_File, Non_Word_Character, - "illegal character in source word"); - end if; - - if Source'Length = 0 then - Error (Dictionary_File, "source is empty"); - - elsif Target'Length = 0 then - Error (Dictionary_File, "target is empty"); - - else - Set (Ug_Words, Source, V (Target)); - - -- Ensure that if Source is a sequence of words - -- "WORD1 WORD2 ...", we already have a mapping for - -- "WORD1". - - for J in Source'Range loop - if Source (J) = ' ' then - declare - Prefix : String renames - Source (Source'First .. J - 1); - begin - if not Is_Known_Word (Prefix) then - Error (Dictionary_File, - "prefix '" & Prefix - & "' not known at this point"); - end if; - end; - end if; - end loop; - end if; - end; - end if; - end; - end loop; - end Read_Dictionary_File; - - ------------------------- - -- Rewrite_Source_Line -- - ------------------------- - - function Rewrite_Source_Line (Line : String) return String is - - -- We use a simple lexer to split the line into tokens: - - -- Word consisting entirely of Word_Characters - -- VMS_Alternative ^alpha^beta^ replacement (but not ^^^) - -- Space a space character - -- Other everything else (sequence of non-word characters) - -- VMS_Error incomplete VMS alternative - -- End_Of_Line no more characters on this line - - -- A sequence of three VMS_Escape_Characters is automatically - -- collapsed to an Other token. - - type Token_Span is record - First, Last : Positive; - end record; - -- The character range covered by a token in Line - - type Token_Kind is (End_Of_Line, Word, Other, - VMS_Alternative, VMS_Error); - type Token_Record (Kind : Token_Kind := End_Of_Line) is record - First : Positive; - case Kind is - when Word | Other => - Span : Token_Span; - when VMS_Alternative => - Non_VMS, VMS : Token_Span; - when VMS_Error | End_Of_Line => - null; - end case; - end record; - - Input_Position : Positive := Line'First; - Token : Token_Record; - -- The position of the next character to be processed by Next_Token - - procedure Next_Token; - -- Returns the next token in Line, starting at Input_Position - - Rewritten_Line : VString; - -- Collects the line as it is rewritten - - procedure Rewrite_Word; - -- The current token is assumed to be a Word. When processing the VMS - -- version of the manual, additional tokens are gathered to check if - -- we have a file name or a sequence of known words. - - procedure Maybe_Rewrite_Extension; - -- The current token is assumed to be Other. When processing the VMS - -- version of the manual and the token represents a single dot ".", - -- the following word is rewritten according to the rules for - -- extensions. - - VMS_Token_Seen : Boolean := False; - -- This is set to true if a VMS_Alternative has been encountered, or a - -- ^^^ token. - - ---------------- - -- Next_Token -- - ---------------- - - procedure Next_Token is - Remaining_Line : String renames Line (Input_Position .. Line'Last); - Last_Character : Natural; - - begin - if Remaining_Line'Length = 0 then - Token := (End_Of_Line, Remaining_Line'First); - return; - end if; - - -- ^alpha^beta^, the VMS_Alternative case - - if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then - declare - VMS_Second_Character, VMS_Third_Character : Natural; - - begin - if VMS_Token_Seen then - Error (Source_File, Remaining_Line'First, - "multiple " & VMS_Escape_Character - & " characters on a single line"); - else - VMS_Token_Seen := True; - end if; - - -- Find the second and third escape character. If one of - -- them is not present, generate an error token. - - VMS_Second_Character := - Index (Remaining_Line (Remaining_Line'First + 1 - .. Remaining_Line'Last), - (1 => VMS_Escape_Character)); - - if VMS_Second_Character = 0 then - Input_Position := Remaining_Line'Last + 1; - Token := (VMS_Error, Remaining_Line'First); - return; - end if; - - VMS_Third_Character := - Index (Remaining_Line (VMS_Second_Character + 1 - .. Remaining_Line'Last), - (1 => VMS_Escape_Character)); - - if VMS_Third_Character = 0 then - Input_Position := Remaining_Line'Last + 1; - Token := (VMS_Error, Remaining_Line'First); - return; - end if; - - -- Consume all the characters we are about to include in - -- the token. - - Input_Position := VMS_Third_Character + 1; - - -- Check if we are in a ^^^ situation, and return an Other - -- token in this case. - - if Remaining_Line'First + 1 = VMS_Second_Character - and then Remaining_Line'First + 2 = VMS_Third_Character - then - Token := (Other, Remaining_Line'First, - (Remaining_Line'First, Remaining_Line'First)); - return; - end if; - - Token := (VMS_Alternative, Remaining_Line'First, - (Remaining_Line'First + 1, VMS_Second_Character - 1), - (VMS_Second_Character + 1, VMS_Third_Character - 1)); - return; - end; - end if; - - -- The Word case. Search for characters not in Word_Characters. - -- We have found a word if the first non-word character is not - -- the first character in Remaining_Line, i.e. if Remaining_Line - -- starts with a word character. - - Last_Character := Index (Remaining_Line, Word_Characters, Outside); - if Last_Character /= Remaining_Line'First then - - -- If we haven't found a character which is not in - -- Word_Characters, all remaining characters are part of the - -- current Word token. - - if Last_Character = 0 then - Last_Character := Remaining_Line'Last + 1; - end if; - - Input_Position := Last_Character; - Token := (Word, Remaining_Line'First, - (Remaining_Line'First, Last_Character - 1)); - return; - end if; - - -- Remaining characters are in the Other category. To speed - -- up processing, we collect them together if there are several - -- of them. - - Input_Position := Last_Character + 1; - Token := (Other, - Remaining_Line'First, - (Remaining_Line'First, Last_Character)); - end Next_Token; - - ------------------ - -- Rewrite_Word -- - ------------------ - - procedure Rewrite_Word is - First_Word : String - renames Line (Token.Span.First .. Token.Span.Last); - - begin - -- We do not perform any error checking below, so we can just skip - -- all processing for the non-VMS version. - - if Target /= VMS then - Append (Rewritten_Line, First_Word); - Next_Token; - return; - end if; - - if Is_Known_Word (First_Word) then - - -- If we have a word from the dictionary, we look for the - -- longest possible sequence we can rewrite. - - declare - Seq : Token_Span := Token.Span; - Lost_Space : Boolean := False; - - begin - Next_Token; - loop - if Token.Kind = Other - and then Line (Token.Span.First .. Token.Span.Last) = " " - then - Next_Token; - - if Token.Kind /= Word - or else not Is_Known_Word (Line (Seq.First - .. Token.Span.Last)) - then - -- When we reach this point, the following conditions - -- are true: - - -- Seq is a known word - - -- The previous token was a space character - - -- Seq extended to the current token is not a - -- known word. - - Lost_Space := True; - exit; - - else - -- Extend Seq to cover the current (known) word - - Seq.Last := Token.Span.Last; - Next_Token; - end if; - - else - -- When we reach this point, the following conditions - -- are true: - - -- Seq is a known word - - -- The previous token was a word - - -- The current token is not a space character. - - exit; - end if; - end loop; - - -- Rewrite Seq, and add the lost space if necessary - - Append (Rewritten_Line, - Get_Replacement_Word (Line (Seq.First .. Seq.Last))); - if Lost_Space then - Append (Rewritten_Line, ' '); - end if; - - -- The unknown token will be processed during the - -- next iteration of the main loop. - return; - end; - end if; - - Next_Token; - - if Token.Kind = Other - and then Line (Token.Span.First .. Token.Span.Last) = "." - then - -- Deal with extensions - - Next_Token; - if Token.Kind = Word - and then - Is_Extension (Line (Token.Span.First .. Token.Span.Last)) - then - -- We have discovered a file extension. Convert the file - -- name to upper case. - - Append (Rewritten_Line, - Translate (First_Word, Upper_Case_Map) & '.'); - Append (Rewritten_Line, - Get_Replacement_Extension - (Line (Token.Span.First .. Token.Span.Last))); - Next_Token; - else - -- We already have: Word ".", followed by an unknown token - - Append (Rewritten_Line, First_Word & '.'); - - -- The unknown token will be processed during the next - -- iteration of the main loop. - end if; - - else - -- We have an unknown Word, followed by an unknown token. - -- The unknown token will be processed by the outer loop. - - Append (Rewritten_Line, First_Word); - end if; - end Rewrite_Word; - - ----------------------------- - -- Maybe_Rewrite_Extension -- - ----------------------------- - - procedure Maybe_Rewrite_Extension is - begin - -- Again, we need no special processing in the non-VMS case - - if Target = VMS - and then Line (Token.Span.First .. Token.Span.Last) = "." - then - -- This extension is not preceded by a word, otherwise - -- Rewrite_Word would have handled it. - - Next_Token; - - if Token.Kind = Word - and then Is_Extension (Line (Token.Span.First - .. Token.Span.Last)) - then - Append (Rewritten_Line, '.' & Get_Replacement_Extension - (Line (Token.Span.First .. Token.Span.Last))); - Next_Token; - else - Append (Rewritten_Line, '.'); - end if; - - else - Append (Rewritten_Line, Line (Token.Span.First - .. Token.Span.Last)); - Next_Token; - end if; - end Maybe_Rewrite_Extension; - - -- Start of processing for Process_Source_Line - - begin - -- The following parser recognizes the following special token - -- sequences: - - -- Word "." Word rewrite as file name if second word is extension - -- Word " " Word rewrite as a single word using Ug_Words table - - Next_Token; - loop - case Token.Kind is - when End_Of_Line => - exit; - - when Word => - Rewrite_Word; - - when Other => - Maybe_Rewrite_Extension; - - when VMS_Alternative => - if Target = VMS then - Append (Rewritten_Line, Line (Token.VMS.First - .. Token.VMS.Last)); - else - Append (Rewritten_Line, Line (Token.Non_VMS.First - .. Token.Non_VMS.Last)); - end if; - - Next_Token; - - when VMS_Error => - Error (Source_File, Token.First, "invalid VMS alternative"); - Next_Token; - end case; - end loop; - - return S (Rewritten_Line); - end Rewrite_Source_Line; - - ------------------------- - -- Process_Source_File -- - ------------------------- - - procedure Process_Source_File is - begin - while not End_Of_File (Source_File.Data) loop - declare - Line : constant String := Get_Line (Source_File'Access); - - Rewritten : constant String := Rewrite_Source_Line (Line); - -- We unconditionally rewrite the line so that we can check the - -- syntax of all lines, and not only those which are actually - -- included in the output. - - begin - if First_Time - and then Line'Length > 3 and then Line (1 .. 3) = "@if" - then - Put_Line (Output_File, "@set " & Argument (1)); - First_Time := False; - end if; - - Put_Line (Output_File, Rewritten); - end; - end loop; - end Process_Source_File; - - --------------------------- - -- Initialize_Extensions -- - --------------------------- - - procedure Initialize_Extensions is - - procedure Add (Extension : String); - -- Adds an extension which is replaced with itself (in upper case) - - procedure Add (Extension, Replacement : String); - -- Adds an extension with a custom replacement - - --------- - -- Add -- - --------- - - procedure Add (Extension : String) is - begin - Add (Extension, Translate (Extension, Upper_Case_Map)); - end Add; - - procedure Add (Extension, Replacement : String) is - begin - Set (Extensions, Extension, V (Replacement)); - end Add; - - -- Start of processing for Initialize_Extensions - - begin - -- To avoid performance degradation, increase the constant in the - -- definition of Extensions above if you add more extensions here. - - Add ("o", "OBJ"); - Add ("ads"); - Add ("adb"); - Add ("ali"); - Add ("ada"); - Add ("atb"); - Add ("ats"); - Add ("adc"); - Add ("c"); - end Initialize_Extensions; - - ------------------ - -- Is_Extension -- - ------------------ - - function Is_Extension (Extension : String) return Boolean is - begin - return Present (Extensions, Extension); - end Is_Extension; - - ------------------------------- - -- Get_Replacement_Extension -- - ------------------------------- - - function Get_Replacement_Extension (Extension : String) return String is - begin - return S (Get (Extensions, Extension)); - end Get_Replacement_Extension; - - ------------------- - -- Is_Known_Word -- - ------------------- - - function Is_Known_Word (Word : String) return Boolean is - begin - return Present (Ug_Words, Word); - end Is_Known_Word; - - -------------------------- - -- Get_Replacement_Word -- - -------------------------- - - function Get_Replacement_Word (Word : String) return String is - begin - return S (Get (Ug_Words, Word)); - end Get_Replacement_Word; - --- Start of processing for Xgnatugn - - Valid_Command_Line : Boolean; - Output_File_Name : VString; - -begin - Initialize_Extensions; - Valid_Command_Line := Argument_Count in 3 .. 5; - - -- First argument: Target - - if Valid_Command_Line then - begin - Target := Flag_Type'Value (Argument (1)); - - if not Target'Valid then - Valid_Command_Line := False; - end if; - - exception - when Constraint_Error => - Valid_Command_Line := False; - end; - end if; - - -- Second argument: Source_File - - if Valid_Command_Line then - begin - Source_File.Name := V (Argument (2)); - Open (Source_File.Data, In_File, Argument (2)); - - exception - when Ada.Text_IO.Name_Error => - Valid_Command_Line := False; - end; - end if; - - -- Third argument: Dictionary_File - - if Valid_Command_Line then - begin - Dictionary_File.Name := V (Argument (3)); - Open (Dictionary_File.Data, In_File, Argument (3)); - - exception - when Ada.Text_IO.Name_Error => - Valid_Command_Line := False; - end; - end if; - - -- Fourth argument: Output_File - - if Valid_Command_Line then - if Argument_Count in 4 .. 5 then - Output_File_Name := V (Argument (4)); - else - case Target is - when UNW => - Output_File_Name := V ("gnat_ugn_unw.texi"); - when VMS => - Output_File_Name := V ("gnat_ugn_vms.texi"); - end case; - end if; - - Warnings_Enabled := Argument_Count = 5; - - begin - Create (Output_File, Out_File, S (Output_File_Name)); - - exception - when Ada.Text_IO.Name_Error | Ada.Text_IO.Use_Error => - Valid_Command_Line := False; - end; - end if; - - if not Valid_Command_Line then - Usage; - Set_Exit_Status (Failure); - - else - Read_Dictionary_File; - Close (Dictionary_File.Data); - - -- Main processing starts here - - Process_Source_File; - Close (Output_File); - Close (Source_File.Data); - - New_Line (Standard_Error); - - if Number_Of_Warnings = 0 then - Put_Line (Standard_Error, " NO Warnings"); - - else - Put (Standard_Error, Integer'Image (Number_Of_Warnings)); - Put (Standard_Error, " Warning"); - - if Number_Of_Warnings > 1 then - Put (Standard_Error, "s"); - end if; - - New_Line (Standard_Error); - end if; - - if Number_Of_Errors = 0 then - Put_Line (Standard_Error, " NO Errors"); - - else - Put (Standard_Error, Integer'Image (Number_Of_Errors)); - Put (Standard_Error, " Error"); - - if Number_Of_Errors > 1 then - Put (Standard_Error, "s"); - end if; - - New_Line (Standard_Error); - end if; - - if Number_Of_Errors /= 0 then - Set_Exit_Status (Failure); - else - Set_Exit_Status (Success); - end if; - end if; -end Xgnatugn; diff --git a/main/gcc/ada/xr_tabls.adb b/main/gcc/ada/xr_tabls.adb index 4b82b035e99..0b97c121da2 100644 --- a/main/gcc/ada/xr_tabls.adb +++ b/main/gcc/ada/xr_tabls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,6 @@ with Types; use Types; with Osint; -with Hostparm; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; @@ -1137,13 +1136,7 @@ package body Xr_Tabls is Buffer (Read_Ptr) := EOF; Contents := new String'(Buffer (1 .. Read_Ptr)); - -- Things are not simple on VMS due to the plethora of file types - -- and organizations. It seems clear that there shouldn't be more - -- bytes read than are contained in the file though. - - if (Hostparm.OpenVMS and then Read_Ptr > Length + 1) - or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1) - then + if Read_Ptr /= Length + 1 then raise Ada.Text_IO.End_Error; end if; diff --git a/main/gcc/ada/xr_tabls.ads b/main/gcc/ada/xr_tabls.ads index b328b82b903..03949ced0bf 100644 --- a/main/gcc/ada/xr_tabls.ads +++ b/main/gcc/ada/xr_tabls.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -288,9 +288,7 @@ package Xr_Tabls is -- character will be added to the returned Contents to simplify parsing. -- Name_Error is raised if the file was not found. End_Error is raised if -- the file could not be read correctly. For most systems correct reading - -- means that the number of bytes read is equal to the file size. The - -- exception is OpenVMS where correct reading means that the number of - -- bytes read is less than or equal to the file size. + -- means that the number of bytes read is equal to the file size. private type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record diff --git a/main/gcc/ada/xsnamest.adb b/main/gcc/ada/xsnamest.adb index a22eec02aa7..a7fbb2ad649 100644 --- a/main/gcc/ada/xsnamest.adb +++ b/main/gcc/ada/xsnamest.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT is 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,10 +255,6 @@ begin Name0 := 'O' & Translate (Name0, Lower_Case_Map); end if; - if Name0 = "error" then - Name0 := V (""); - end if; - if not Match (Name0, Chk_Low) then Put_Line (OutB, " """ & Name0 & "#"" &"); end if; diff --git a/main/gcc/asan.c b/main/gcc/asan.c index 59ec904ccc3..76f21bd7020 100644 --- a/main/gcc/asan.c +++ b/main/gcc/asan.c @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "internal-fn.h" #include "gimple-expr.h" #include "is-a.h" +#include "inchash.h" #include "gimple.h" #include "gimplify.h" #include "gimple-iterator.h" @@ -347,9 +348,10 @@ struct asan_mem_ref_hasher inline hashval_t asan_mem_ref_hasher::hash (const asan_mem_ref *mem_ref) { - hashval_t h = iterative_hash_expr (mem_ref->start, 0); - h = iterative_hash_host_wide_int (mem_ref->access_size, h); - return h; + inchash::hash hstate; + inchash::add_expr (mem_ref->start, hstate); + hstate.add_wide_int (mem_ref->access_size); + return hstate.end (); } /* Compare two memory references. We accept the length of either @@ -2748,21 +2750,25 @@ pass_sanopt::execute (function *fun) FOR_EACH_BB_FN (bb, fun) { gimple_stmt_iterator gsi; - for (gsi = gsi_start_bb (bb); !gsi_end_p (gsi); gsi_next (&gsi)) + for (gsi = gsi_start_bb (bb); !gsi_end_p (gsi); ) { gimple stmt = gsi_stmt (gsi); + bool no_next = false; if (!is_gimple_call (stmt)) - continue; + { + gsi_next (&gsi); + continue; + } if (gimple_call_internal_p (stmt)) switch (gimple_call_internal_fn (stmt)) { case IFN_UBSAN_NULL: - ubsan_expand_null_ifn (gsi); + no_next = ubsan_expand_null_ifn (&gsi); break; case IFN_UBSAN_BOUNDS: - ubsan_expand_bounds_ifn (&gsi); + no_next = ubsan_expand_bounds_ifn (&gsi); break; default: break; @@ -2775,9 +2781,8 @@ pass_sanopt::execute (function *fun) fprintf (dump_file, "\n"); } - /* ubsan_expand_bounds_ifn might move us to the end of the BB. */ - if (gsi_end_p (gsi)) - break; + if (!no_next) + gsi_next (&gsi); } } return 0; diff --git a/main/gcc/c-family/ChangeLog b/main/gcc/c-family/ChangeLog index 81ec2568af2..b599627c397 100644 --- a/main/gcc/c-family/ChangeLog +++ b/main/gcc/c-family/ChangeLog @@ -1,3 +1,52 @@ +2014-08-03 Marek Polacek + + * c-common.c (check_case_value): Add location_t parameter. Use it. + (c_add_case_label): Pass loc to check_case_value. + +2014-08-02 Trevor Saunders + + * cilk.c: Use hash_map instead of pointer_map. + +2014-08-02 Trevor Saunders + + * c-gimplify.c: Use hash_set instead of pointer_set. + +2014-08-01 Igor Zamyatin + + PR middle-end/61455 + * array-notation-common.c (extract_array_notation_exprs): Handling + of DECL_EXPR added. + +2014-08-01 Jakub Jelinek + + * c-common.h (min_align_of_type): Removed prototype. + * c-common.c (min_align_of_type): Removed. + * c-ubsan.h (ubsan_maybe_instrument_reference, + ubsan_maybe_instrument_member_call): New prototypes. + * c-ubsan.c: Include stor-layout.h and builtins.h. + (ubsan_maybe_instrument_reference_or_call, + ubsan_maybe_instrument_reference, ubsan_maybe_instrument_call): New + functions. + +2014-07-31 Marc Glisse + + PR c++/60517 + * c.opt (-Wreturn-local-addr): Move to common.opt. + +2014-07-30 Jason Merrill + + PR c++/61659 + PR c++/61687 + Revert: + * c.opt (-fuse-all-virtuals): New. + +2014-07-30 Tom Tromey + + PR c/59855 + * c.opt (Wdesignated-init): New option. + * c-common.c (c_common_attribute_table): Add "designated_init". + (handle_designated_init): New function. + 2014-07-24 Marek Polacek PR c/57653 diff --git a/main/gcc/c-family/array-notation-common.c b/main/gcc/c-family/array-notation-common.c index c0100398a8b..84f6f452799 100644 --- a/main/gcc/c-family/array-notation-common.c +++ b/main/gcc/c-family/array-notation-common.c @@ -329,6 +329,14 @@ extract_array_notation_exprs (tree node, bool ignore_builtin_fn, vec_safe_push (*array_list, node); return; } + if (TREE_CODE (node) == DECL_EXPR) + { + tree x = DECL_EXPR_DECL (node); + if (DECL_INITIAL (x)) + extract_array_notation_exprs (DECL_INITIAL (x), + ignore_builtin_fn, + array_list); + } else if (TREE_CODE (node) == STATEMENT_LIST) { tree_stmt_iterator ii_tsi; diff --git a/main/gcc/c-family/c-common.c b/main/gcc/c-family/c-common.c index 69d937f2789..ea5670b85c0 100644 --- a/main/gcc/c-family/c-common.c +++ b/main/gcc/c-family/c-common.c @@ -300,7 +300,7 @@ const struct fname_var_t fname_vars[] = struct visibility_flags visibility_options; static tree c_fully_fold_internal (tree expr, bool, bool *, bool *); -static tree check_case_value (tree); +static tree check_case_value (location_t, tree); static bool check_case_bounds (location_t, tree, tree, tree *, tree *); static tree handle_packed_attribute (tree *, tree, tree, int, bool *); @@ -380,6 +380,7 @@ static tree handle_omp_declare_simd_attribute (tree *, tree, tree, int, bool *); static tree handle_omp_declare_target_attribute (tree *, tree, tree, int, bool *); +static tree handle_designated_init_attribute (tree *, tree, tree, int, bool *); static tree handle_always_patch_for_instrumentation_attribute (tree *, tree, tree, int, @@ -787,6 +788,8 @@ const struct attribute_spec c_common_attribute_table[] = handle_alloc_align_attribute, false }, { "assume_aligned", 1, 2, false, true, true, handle_assume_aligned_attribute, false }, + { "designated_init", 0, 0, false, true, false, + handle_designated_init_attribute, false }, { NULL, 0, 0, false, false, false, NULL, false } }; @@ -3360,7 +3363,7 @@ verify_sequence_points (tree expr) /* Validate the expression after `case' and apply default promotions. */ static tree -check_case_value (tree value) +check_case_value (location_t loc, tree value) { if (value == NULL_TREE) return value; @@ -3370,7 +3373,7 @@ check_case_value (tree value) value = perform_integral_promotions (value); else if (value != error_mark_node) { - error ("case label does not reduce to an integer constant"); + error_at (loc, "case label does not reduce to an integer constant"); value = error_mark_node; } @@ -4976,26 +4979,6 @@ c_common_get_alias_set (tree t) return -1; } -/* Return the least alignment required for type TYPE. */ - -unsigned int -min_align_of_type (tree type) -{ - unsigned int align = TYPE_ALIGN (type); - align = MIN (align, BIGGEST_ALIGNMENT); -#ifdef BIGGEST_FIELD_ALIGNMENT - align = MIN (align, BIGGEST_FIELD_ALIGNMENT); -#endif - unsigned int field_align = align; -#ifdef ADJUST_FIELD_ALIGN - tree field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, NULL_TREE, - type); - field_align = ADJUST_FIELD_ALIGN (field, field_align); -#endif - align = MIN (align, field_align); - return align / BITS_PER_UNIT; -} - /* Compute the value of 'sizeof (TYPE)' or '__alignof__ (TYPE)', where the IS_SIZEOF parameter indicates which operator is being applied. The COMPLAIN flag controls whether we should diagnose possibly @@ -6024,14 +6007,14 @@ c_add_case_label (location_t loc, splay_tree cases, tree cond, tree orig_type, type = TREE_TYPE (cond); if (low_value) { - low_value = check_case_value (low_value); + low_value = check_case_value (loc, low_value); low_value = convert_and_check (loc, type, low_value); if (low_value == error_mark_node) goto error_out; } if (high_value) { - high_value = check_case_value (high_value); + high_value = check_case_value (loc, high_value); high_value = convert_and_check (loc, type, high_value); if (high_value == error_mark_node) goto error_out; @@ -9331,6 +9314,21 @@ handle_returns_nonnull_attribute (tree *node, tree, tree, int, return NULL_TREE; } +/* Handle a "designated_init" attribute; arguments as in + struct attribute_spec.handler. */ + +static tree +handle_designated_init_attribute (tree *node, tree name, tree, int, + bool *no_add_attrs) +{ + if (TREE_CODE (*node) != RECORD_TYPE) + { + error ("%qE attribute is only valid on % type", name); + *no_add_attrs = true; + } + return NULL_TREE; +} + /* Check for valid arguments being passed to a function with FNTYPE. There are NARGS arguments in the array ARGARRAY. */ diff --git a/main/gcc/c-family/c-common.h b/main/gcc/c-family/c-common.h index d3c55490030..a84aeabbd4e 100644 --- a/main/gcc/c-family/c-common.h +++ b/main/gcc/c-family/c-common.h @@ -762,7 +762,6 @@ extern tree c_wrap_maybe_const (tree, bool); extern tree c_save_expr (tree); extern tree c_common_truthvalue_conversion (location_t, tree); extern void c_apply_type_quals_to_decl (int, tree); -extern unsigned int min_align_of_type (tree); extern tree c_sizeof_or_alignof_type (location_t, tree, bool, bool, int); extern tree c_alignof_expr (location_t, tree); /* Print an error message for invalid operands to arith operation CODE. diff --git a/main/gcc/c-family/c-gimplify.c b/main/gcc/c-family/c-gimplify.c index 2b5ce5ba86f..489821757ed 100644 --- a/main/gcc/c-family/c-gimplify.c +++ b/main/gcc/c-family/c-gimplify.c @@ -74,7 +74,7 @@ along with GCC; see the file COPYING3. If not see static tree ubsan_walk_array_refs_r (tree *tp, int *walk_subtrees, void *data) { - struct pointer_set_t *pset = (struct pointer_set_t *) data; + hash_set *pset = (hash_set *) data; /* Since walk_tree doesn't call the callback function on the decls in BIND_EXPR_VARS, we have to walk them manually. */ @@ -116,10 +116,9 @@ c_genericize (tree fndecl) if (flag_sanitize & SANITIZE_BOUNDS) { - struct pointer_set_t *pset = pointer_set_create (); - walk_tree (&DECL_SAVED_TREE (fndecl), ubsan_walk_array_refs_r, pset, - pset); - pointer_set_destroy (pset); + hash_set pset; + walk_tree (&DECL_SAVED_TREE (fndecl), ubsan_walk_array_refs_r, &pset, + &pset); } /* Dump the C-specific tree IR. */ diff --git a/main/gcc/c-family/c-ubsan.c b/main/gcc/c-family/c-ubsan.c index ad5dd0bf92a..e048c53ac3e 100644 --- a/main/gcc/c-family/c-ubsan.c +++ b/main/gcc/c-family/c-ubsan.c @@ -31,6 +31,8 @@ along with GCC; see the file COPYING3. If not see #include "c-family/c-ubsan.h" #include "asan.h" #include "internal-fn.h" +#include "stor-layout.h" +#include "builtins.h" /* Instrument division by zero and INT_MIN / -1. If not instrumenting, return NULL_TREE. */ @@ -350,3 +352,99 @@ ubsan_maybe_instrument_array_ref (tree *expr_p, bool ignore_off_by_one) } } } + +static tree +ubsan_maybe_instrument_reference_or_call (location_t loc, tree op, tree type, + enum ubsan_null_ckind ckind) +{ + tree orig_op = op; + bool instrument = false; + unsigned int mina = 0; + + if (current_function_decl == NULL_TREE + || lookup_attribute ("no_sanitize_undefined", + DECL_ATTRIBUTES (current_function_decl))) + return NULL_TREE; + + if (flag_sanitize & SANITIZE_ALIGNMENT) + { + mina = min_align_of_type (type); + if (mina <= 1) + mina = 0; + } + while ((TREE_CODE (op) == NOP_EXPR + || TREE_CODE (op) == NON_LVALUE_EXPR) + && TREE_CODE (TREE_TYPE (op)) == POINTER_TYPE) + op = TREE_OPERAND (op, 0); + if (TREE_CODE (op) == NOP_EXPR + && TREE_CODE (TREE_TYPE (op)) == REFERENCE_TYPE) + { + if (mina && mina > min_align_of_type (TREE_TYPE (TREE_TYPE (op)))) + instrument = true; + } + else + { + if ((flag_sanitize & SANITIZE_NULL) && TREE_CODE (op) == ADDR_EXPR) + { + bool strict_overflow_p = false; + /* tree_single_nonzero_warnv_p will not return true for non-weak + non-automatic decls with -fno-delete-null-pointer-checks, + which is disabled during -fsanitize=null. We don't want to + instrument those, just weak vars though. */ + int save_flag_delete_null_pointer_checks + = flag_delete_null_pointer_checks; + flag_delete_null_pointer_checks = 1; + if (!tree_single_nonzero_warnv_p (op, &strict_overflow_p) + || strict_overflow_p) + instrument = true; + flag_delete_null_pointer_checks + = save_flag_delete_null_pointer_checks; + } + else if (flag_sanitize & SANITIZE_NULL) + instrument = true; + if (mina && mina > get_pointer_alignment (op) / BITS_PER_UNIT) + instrument = true; + } + if (!instrument) + return NULL_TREE; + op = save_expr (orig_op); + tree kind = build_int_cst (TREE_TYPE (op), ckind); + tree align = build_int_cst (pointer_sized_int_node, mina); + tree call + = build_call_expr_internal_loc (loc, IFN_UBSAN_NULL, void_type_node, + 3, op, kind, align); + TREE_SIDE_EFFECTS (call) = 1; + return fold_build2 (COMPOUND_EXPR, TREE_TYPE (op), call, op); +} + +/* Instrument a NOP_EXPR to REFERENCE_TYPE if needed. */ + +void +ubsan_maybe_instrument_reference (tree stmt) +{ + tree op = TREE_OPERAND (stmt, 0); + op = ubsan_maybe_instrument_reference_or_call (EXPR_LOCATION (stmt), op, + TREE_TYPE (TREE_TYPE (stmt)), + UBSAN_REF_BINDING); + if (op) + TREE_OPERAND (stmt, 0) = op; +} + +/* Instrument a CALL_EXPR to a method if needed. */ + +void +ubsan_maybe_instrument_member_call (tree stmt, bool is_ctor) +{ + if (call_expr_nargs (stmt) == 0) + return; + tree op = CALL_EXPR_ARG (stmt, 0); + if (op == error_mark_node + || !POINTER_TYPE_P (TREE_TYPE (op))) + return; + op = ubsan_maybe_instrument_reference_or_call (EXPR_LOCATION (stmt), op, + TREE_TYPE (TREE_TYPE (op)), + is_ctor ? UBSAN_CTOR_CALL + : UBSAN_MEMBER_CALL); + if (op) + CALL_EXPR_ARG (stmt, 0) = op; +} diff --git a/main/gcc/c-family/c-ubsan.h b/main/gcc/c-family/c-ubsan.h index edf5bc60be6..7feec45db06 100644 --- a/main/gcc/c-family/c-ubsan.h +++ b/main/gcc/c-family/c-ubsan.h @@ -28,5 +28,7 @@ extern tree ubsan_instrument_return (location_t); extern tree ubsan_instrument_bounds (location_t, tree, tree *, bool); extern bool ubsan_array_ref_instrumented_p (const_tree); extern void ubsan_maybe_instrument_array_ref (tree *, bool); +extern void ubsan_maybe_instrument_reference (tree); +extern void ubsan_maybe_instrument_member_call (tree, bool); #endif /* GCC_C_UBSAN_H */ diff --git a/main/gcc/c-family/c.opt b/main/gcc/c-family/c.opt index 766718b4e51..0491a298390 100644 --- a/main/gcc/c-family/c.opt +++ b/main/gcc/c-family/c.opt @@ -363,6 +363,10 @@ Wdeprecated C C++ ObjC ObjC++ Var(warn_deprecated) Init(1) Warning Warn if a deprecated compiler feature, class, method, or field is used +Wdesignated-init +C ObjC Var(warn_designated_init) Init(1) Warning +Warn about positional initialization of structs requiring designated initializers + Wdiscarded-qualifiers C ObjC Var(warn_discarded_qualifiers) Init(1) Warning Warn if type qualifiers on pointers are discarded @@ -709,10 +713,6 @@ Wreorder C++ ObjC++ Var(warn_reorder) Warning LangEnabledBy(C++ ObjC++,Wall) Warn when the compiler reorders code -Wreturn-local-addr -C ObjC C++ ObjC++ Var(warn_return_local_addr) Init(1) Warning -Warn about returning a pointer/reference to a local or temporary variable. - Wreturn-type C ObjC C++ ObjC++ Var(warn_return_type) Warning LangEnabledBy(C ObjC C++ ObjC++,Wall) Warn whenever a function's return type defaults to \"int\" (C), or about inconsistent return types (C++) @@ -1276,10 +1276,6 @@ funsigned-char C ObjC C++ ObjC++ LTO Var(flag_signed_char, 0) Make \"char\" unsigned by default -fuse-all-virtuals -C++ ObjC++ Var(flag_use_all_virtuals) Init(1) -Treat all virtual functions as odr-used - fuse-cxa-atexit C++ ObjC++ Var(flag_use_cxa_atexit) Init(DEFAULT_USE_CXA_ATEXIT) Use __cxa_atexit to register destructors diff --git a/main/gcc/c-family/cilk.c b/main/gcc/c-family/cilk.c index b864bb1eb63..e0d114128ab 100644 --- a/main/gcc/c-family/cilk.c +++ b/main/gcc/c-family/cilk.c @@ -64,7 +64,7 @@ struct wrapper_data /* Containing function. */ tree context; /* Disposition of all variables in the inner statement. */ - struct pointer_map_t *decl_map; + hash_map *decl_map; /* True if this function needs a static chain. */ bool nested; /* Arguments to be passed to wrapper function, currently a list. */ @@ -335,12 +335,11 @@ create_cilk_helper_decl (struct wrapper_data *wd) /* A function used by walk tree to find wrapper parms. */ -static bool -wrapper_parm_cb (const void *key0, void **val0, void *data) +bool +wrapper_parm_cb (tree const &key0, tree *val0, wrapper_data *wd) { - struct wrapper_data *wd = (struct wrapper_data *) data; - tree arg = * (tree *)&key0; - tree val = (tree)*val0; + tree arg = key0; + tree val = *val0; tree parm; if (val == error_mark_node || val == arg) @@ -387,7 +386,7 @@ build_wrapper_type (struct wrapper_data *wd) wd->parms = NULL_TREE; wd->argtypes = void_list_node; - pointer_map_traverse (wd->decl_map, wrapper_parm_cb, wd); + wd->decl_map->traverse (wd); gcc_assert (wd->type != CILK_BLOCK_FOR); /* Now build a function. @@ -452,25 +451,22 @@ copy_decl_for_cilk (tree decl, copy_body_data *id) /* Copy all local variables. */ -static bool -for_local_cb (const void *k_v, void **vp, void *p) +bool +for_local_cb (tree const &k, tree *vp, copy_body_data *id) { - tree k = *(tree *) &k_v; - tree v = (tree) *vp; + tree v = *vp; if (v == error_mark_node) - *vp = copy_decl_no_change (k, (copy_body_data *) p); + *vp = copy_decl_no_change (k, id); return true; } /* Copy all local declarations from a _Cilk_spawned function's body. */ -static bool -wrapper_local_cb (const void *k_v, void **vp, void *data) +bool +wrapper_local_cb (tree const &key, tree *vp, copy_body_data *id) { - copy_body_data *id = (copy_body_data *) data; - tree key = *(tree *) &k_v; - tree val = (tree) *vp; + tree val = *vp; if (val == error_mark_node) *vp = copy_decl_for_cilk (key, id); @@ -514,8 +510,11 @@ cilk_outline (tree inner_fn, tree *stmt_p, void *w) insert_decl_map (&id, wd->block, DECL_INITIAL (inner_fn)); /* We don't want the private variables any more. */ - pointer_map_traverse (wd->decl_map, nested ? for_local_cb : wrapper_local_cb, - &id); + if (nested) + wd->decl_map->traverse (&id); + else + wd->decl_map->traverse (&id); + walk_tree (stmt_p, copy_tree_body_r, (void *) &id, NULL); /* See if this function can throw or calls something that should @@ -576,7 +575,7 @@ init_wd (struct wrapper_data *wd, enum cilk_block_type type) wd->type = type; wd->fntype = NULL_TREE; wd->context = current_function_decl; - wd->decl_map = pointer_map_create (); + wd->decl_map = new hash_map; /* _Cilk_for bodies are always nested. Others start off as normal functions. */ wd->nested = (type == CILK_BLOCK_FOR); @@ -590,7 +589,7 @@ init_wd (struct wrapper_data *wd, enum cilk_block_type type) static void free_wd (struct wrapper_data *wd) { - pointer_map_destroy (wd->decl_map); + delete wd->decl_map; wd->nested = false; wd->arglist = NULL_TREE; wd->argtypes = NULL_TREE; @@ -618,12 +617,11 @@ free_wd (struct wrapper_data *wd) (var, ???) -- Pure output argument, handled similarly to above. */ -static bool -declare_one_free_variable (const void *var0, void **map0, - void *data ATTRIBUTE_UNUSED) +bool +declare_one_free_variable (tree const &var0, tree *map0, wrapper_data &) { - const_tree var = (const_tree) var0; - tree map = (tree)*map0; + const_tree var = var0; + tree map = *map0; tree var_type = TREE_TYPE (var), arg_type; bool by_reference; tree parm; @@ -713,7 +711,7 @@ create_cilk_wrapper (tree exp, tree *args_out) } else extract_free_variables (exp, &wd, ADD_READ); - pointer_map_traverse (wd.decl_map, declare_one_free_variable, &wd); + wd.decl_map->traverse (wd); wd.block = TREE_BLOCK (exp); if (!wd.block) wd.block = DECL_INITIAL (current_function_decl); @@ -884,9 +882,7 @@ cilk_install_body_pedigree_operations (tree frame_ptr) static void add_variable (struct wrapper_data *wd, tree var, enum add_variable_type how) { - void **valp; - - valp = pointer_map_contains (wd->decl_map, (void *) var); + tree *valp = wd->decl_map->get (var); if (valp) { tree val = (tree) *valp; @@ -907,7 +903,7 @@ add_variable (struct wrapper_data *wd, tree var, enum add_variable_type how) if (how != ADD_WRITE) return; /* This variable might have been entered as read but is now written. */ - *valp = (void *) var; + *valp = var; wd->nested = true; return; } @@ -971,7 +967,7 @@ add_variable (struct wrapper_data *wd, tree var, enum add_variable_type how) break; } } - *pointer_map_insert (wd->decl_map, (void *) var) = val; + wd->decl_map->put (var, val); } } diff --git a/main/gcc/c/ChangeLog b/main/gcc/c/ChangeLog index 01064979897..35d958c1809 100644 --- a/main/gcc/c/ChangeLog +++ b/main/gcc/c/ChangeLog @@ -1,3 +1,32 @@ +2014-08-02 Trevor Saunders + + * c-typeck.c: Use hash_map instead of pointer_map. + +2014-08-02 Trevor Saunders + + * c-decl.c: Use hash_set instead of pointer_set. + +2014-08-01 Igor Zamyatin + + PR middle-end/61455 + * c-array-notation.c (expand_array_notations): Handling + of DECL_EXPR added. + +2014-07-31 Marc Glisse + + PR c++/60517 + * c-typeck.c (c_finish_return): Return 0 instead of the address of + a local variable. + +2014-07-30 Tom Tromey + + * c-typeck.c (struct constructor_stack) : New + field. + (really_start_incremental_init, push_init_level): Initialize + designator_depth. + (pop_init_level): Set global designator_depth. + (process_init_element): Check for designated_init attribute. + 2014-07-20 Marek Polacek PR c/61852 diff --git a/main/gcc/c/c-array-notation.c b/main/gcc/c/c-array-notation.c index 67a89315e9c..597adc912a6 100644 --- a/main/gcc/c/c-array-notation.c +++ b/main/gcc/c/c-array-notation.c @@ -1265,6 +1265,25 @@ expand_array_notations (tree *tp, int *walk_subtrees, void *) rhs_loc, rhs, TREE_TYPE (rhs)); } break; + case DECL_EXPR: + { + tree x = DECL_EXPR_DECL (*tp); + if (DECL_INITIAL (x)) + { + location_t loc = DECL_SOURCE_LOCATION (x); + tree lhs = x; + tree rhs = DECL_INITIAL (x); + DECL_INITIAL (x) = NULL; + tree new_modify_expr = build_modify_expr (loc, lhs, + TREE_TYPE (lhs), + NOP_EXPR, + loc, rhs, + TREE_TYPE(rhs)); + expand_array_notations (&new_modify_expr, walk_subtrees, NULL); + *tp = new_modify_expr; + } + } + break; case CALL_EXPR: *tp = fix_array_notation_call_expr (*tp); break; diff --git a/main/gcc/c/c-decl.c b/main/gcc/c/c-decl.c index c7893b2dfb8..242e9a2ea17 100644 --- a/main/gcc/c/c-decl.c +++ b/main/gcc/c/c-decl.c @@ -59,7 +59,7 @@ along with GCC; see the file COPYING3. If not see #include "cgraph.h" #include "hash-table.h" #include "langhooks-def.h" -#include "pointer-set.h" +#include "hash-set.h" #include "l-ipo.h" #include "plugin.h" #include "c-family/c-ada-spec.h" @@ -7300,17 +7300,17 @@ warn_cxx_compat_finish_struct (tree fieldlist) if (!struct_parse_info->typedefs_seen.is_empty () && fieldlist != NULL_TREE) { - /* Use a pointer_set using the name of the typedef. We can use - a pointer_set because identifiers are interned. */ - struct pointer_set_t *tset = pointer_set_create (); + /* Use a hash_set using the name of the typedef. We can use + a hash_set because identifiers are interned. */ + hash_set tset; FOR_EACH_VEC_ELT (struct_parse_info->typedefs_seen, ix, x) - pointer_set_insert (tset, DECL_NAME (x)); + tset.add (DECL_NAME (x)); for (x = fieldlist; x != NULL_TREE; x = DECL_CHAIN (x)) { if (DECL_NAME (x) != NULL_TREE - && pointer_set_contains (tset, DECL_NAME (x))) + && tset.contains (DECL_NAME (x))) { warning_at (DECL_SOURCE_LOCATION (x), OPT_Wc___compat, ("using %qD as both field and typedef name is " @@ -7320,8 +7320,6 @@ warn_cxx_compat_finish_struct (tree fieldlist) the typedef name is used. */ } } - - pointer_set_destroy (tset); } /* For each field which has a binding and which was not defined in @@ -8268,7 +8266,7 @@ store_parm_decls_oldstyle (tree fndecl, const struct c_arg_info *arg_info) struct c_binding *b; tree parm, decl, last; tree parmids = arg_info->parms; - struct pointer_set_t *seen_args = pointer_set_create (); + hash_set seen_args; if (!in_system_header_at (input_location)) warning_at (DECL_SOURCE_LOCATION (fndecl), @@ -8299,7 +8297,7 @@ store_parm_decls_oldstyle (tree fndecl, const struct c_arg_info *arg_info) "%qD declared as a non-parameter", decl); /* If the declaration is already marked, we have a duplicate name. Complain and ignore the duplicate. */ - else if (pointer_set_contains (seen_args, decl)) + else if (seen_args.contains (decl)) { error_at (DECL_SOURCE_LOCATION (decl), "multiple parameters named %qD", decl); @@ -8348,7 +8346,7 @@ store_parm_decls_oldstyle (tree fndecl, const struct c_arg_info *arg_info) } TREE_PURPOSE (parm) = decl; - pointer_set_insert (seen_args, decl); + seen_args.add (decl); } /* Now examine the parms chain for incomplete declarations @@ -8368,7 +8366,7 @@ store_parm_decls_oldstyle (tree fndecl, const struct c_arg_info *arg_info) TREE_TYPE (parm) = error_mark_node; } - if (!pointer_set_contains (seen_args, parm)) + if (!seen_args.contains (parm)) { error_at (DECL_SOURCE_LOCATION (parm), "declaration for parameter %qD but no such parameter", @@ -8403,8 +8401,6 @@ store_parm_decls_oldstyle (tree fndecl, const struct c_arg_info *arg_info) DECL_CHAIN (last) = 0; } - pointer_set_destroy (seen_args); - /* If there was a previous prototype, set the DECL_ARG_TYPE of each argument according to the type previously specified, and report any mismatches. */ diff --git a/main/gcc/c/c-typeck.c b/main/gcc/c/c-typeck.c index 06fd565f770..1b664bd0258 100644 --- a/main/gcc/c/c-typeck.c +++ b/main/gcc/c/c-typeck.c @@ -6956,6 +6956,7 @@ struct constructor_stack char outer; char incremental; char designated; + int designator_depth; }; static struct constructor_stack *constructor_stack; @@ -7127,6 +7128,7 @@ really_start_incremental_init (tree type) p->outer = 0; p->incremental = constructor_incremental; p->designated = constructor_designated; + p->designator_depth = designator_depth; p->next = 0; constructor_stack = p; @@ -7276,6 +7278,7 @@ push_init_level (location_t loc, int implicit, p->outer = 0; p->incremental = constructor_incremental; p->designated = constructor_designated; + p->designator_depth = designator_depth; p->next = constructor_stack; p->range_stack = 0; constructor_stack = p; @@ -7583,6 +7586,7 @@ pop_init_level (location_t loc, int implicit, constructor_erroneous = p->erroneous; constructor_incremental = p->incremental; constructor_designated = p->designated; + designator_depth = p->designator_depth; constructor_pending_elts = p->pending_elts; constructor_depth = p->depth; if (!p->implicit) @@ -8652,6 +8656,15 @@ process_init_element (location_t loc, struct c_expr value, bool implicit, if (constructor_type == 0) return; + if (!implicit && warn_designated_init && !was_designated + && TREE_CODE (constructor_type) == RECORD_TYPE + && lookup_attribute ("designated_init", + TYPE_ATTRIBUTES (constructor_type))) + warning_init (loc, + OPT_Wdesignated_init, + "positional initialization of field " + "in % declared with % attribute"); + /* If we've exhausted any levels that didn't have braces, pop them now. */ while (constructor_stack->implicit) @@ -9337,8 +9350,12 @@ c_finish_return (location_t loc, tree retval, tree origtype) warning_at (loc, OPT_Wreturn_local_addr, "function returns address of label"); else - warning_at (loc, OPT_Wreturn_local_addr, - "function returns address of local variable"); + { + warning_at (loc, OPT_Wreturn_local_addr, + "function returns address of local variable"); + tree zero = build_zero_cst (TREE_TYPE (res)); + t = build2 (COMPOUND_EXPR, TREE_TYPE (res), t, zero); + } } break; @@ -11783,15 +11800,15 @@ c_clone_omp_udr (tree stmt, tree omp_decl1, tree omp_decl2, tree decl, tree placeholder) { copy_body_data id; - struct pointer_map_t *decl_map = pointer_map_create (); + hash_map decl_map; - *pointer_map_insert (decl_map, omp_decl1) = placeholder; - *pointer_map_insert (decl_map, omp_decl2) = decl; + decl_map.put (omp_decl1, placeholder); + decl_map.put (omp_decl2, decl); memset (&id, 0, sizeof (id)); id.src_fn = DECL_CONTEXT (omp_decl1); id.dst_fn = current_function_decl; id.src_cfun = DECL_STRUCT_FUNCTION (id.src_fn); - id.decl_map = decl_map; + id.decl_map = &decl_map; id.copy_decl = copy_decl_no_change; id.transform_call_graph_edges = CB_CGE_DUPLICATE; @@ -11800,7 +11817,6 @@ c_clone_omp_udr (tree stmt, tree omp_decl1, tree omp_decl2, id.transform_lang_insert_block = NULL; id.eh_lp_nr = 0; walk_tree (&stmt, copy_tree_body_r, &id, NULL); - pointer_map_destroy (decl_map); return stmt; } diff --git a/main/gcc/calls.c b/main/gcc/calls.c index 78fe7d8525b..e8456528a59 100644 --- a/main/gcc/calls.c +++ b/main/gcc/calls.c @@ -1937,7 +1937,7 @@ load_register_parameters (struct arg_data *args, int num_actuals, else if (partial == 0 || args[i].pass_on_stack) { - rtx mem = validize_mem (args[i].value); + rtx mem = validize_mem (copy_rtx (args[i].value)); /* Check for overlap with already clobbered argument area, providing that this has non-zero size. */ @@ -4014,7 +4014,8 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, argvec[argnum].locate.size.constant ); - emit_block_move (validize_mem (argvec[argnum].save_area), + emit_block_move (validize_mem + (copy_rtx (argvec[argnum].save_area)), stack_area, GEN_INT (argvec[argnum].locate.size.constant), BLOCK_OP_CALL_PARM); @@ -4289,7 +4290,8 @@ emit_library_call_value_1 (int retval, rtx orgfun, rtx value, if (save_mode == BLKmode) emit_block_move (stack_area, - validize_mem (argvec[count].save_area), + validize_mem + (copy_rtx (argvec[count].save_area)), GEN_INT (argvec[count].locate.size.constant), BLOCK_OP_CALL_PARM); else @@ -4433,7 +4435,8 @@ store_one_arg (struct arg_data *arg, rtx argblock, int flags, arg->save_area = assign_temp (TREE_TYPE (arg->tree_value), 1, 1); preserve_temp_slots (arg->save_area); - emit_block_move (validize_mem (arg->save_area), stack_area, + emit_block_move (validize_mem (copy_rtx (arg->save_area)), + stack_area, GEN_INT (arg->locate.size.constant), BLOCK_OP_CALL_PARM); } diff --git a/main/gcc/cfgexpand.c b/main/gcc/cfgexpand.c index 228a7e531fa..65c747af862 100644 --- a/main/gcc/cfgexpand.c +++ b/main/gcc/cfgexpand.c @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "expr.h" #include "langhooks.h" #include "bitmap.h" +#include "hash-set.h" #include "pointer-set.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -597,7 +598,7 @@ stack_var_cmp (const void *a, const void *b) static void add_partitioned_vars_to_ptset (struct pt_solution *pt, struct pointer_map_t *decls_to_partitions, - struct pointer_set_t *visited, bitmap temp) + hash_set *visited, bitmap temp) { bitmap_iterator bi; unsigned i; @@ -607,7 +608,7 @@ add_partitioned_vars_to_ptset (struct pt_solution *pt, || pt->vars == NULL /* The pointed-to vars bitmap is shared, it is enough to visit it once. */ - || pointer_set_insert (visited, pt->vars)) + || visited->add (pt->vars)) return; bitmap_clear (temp); @@ -687,7 +688,7 @@ update_alias_info_with_stack_vars (void) if (decls_to_partitions) { unsigned i; - struct pointer_set_t *visited = pointer_set_create (); + hash_set visited; bitmap temp = BITMAP_ALLOC (&stack_var_bitmap_obstack); for (i = 1; i < num_ssa_names; i++) @@ -699,13 +700,12 @@ update_alias_info_with_stack_vars (void) && POINTER_TYPE_P (TREE_TYPE (name)) && ((pi = SSA_NAME_PTR_INFO (name)) != NULL)) add_partitioned_vars_to_ptset (&pi->pt, decls_to_partitions, - visited, temp); + &visited, temp); } add_partitioned_vars_to_ptset (&cfun->gimple_df->escaped, - decls_to_partitions, visited, temp); + decls_to_partitions, &visited, temp); - pointer_set_destroy (visited); pointer_map_destroy (decls_to_partitions); BITMAP_FREE (temp); } diff --git a/main/gcc/cfgloop.c b/main/gcc/cfgloop.c index 889e9ce8b82..a66c131093f 100644 --- a/main/gcc/cfgloop.c +++ b/main/gcc/cfgloop.c @@ -28,7 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic-core.h" #include "flags.h" #include "tree.h" -#include "pointer-set.h" +#include "hash-set.h" #include "tree-ssa-alias.h" #include "internal-fn.h" #include "gimple-expr.h" @@ -650,11 +650,11 @@ find_subloop_latch_edge (struct loop *loop) /* Callback for make_forwarder_block. Returns true if the edge E is marked in the set MFB_REIS_SET. */ -static struct pointer_set_t *mfb_reis_set; +static hash_set *mfb_reis_set; static bool mfb_redirect_edges_in_set (edge e) { - return pointer_set_contains (mfb_reis_set, e); + return mfb_reis_set->contains (e); } /* Creates a subloop of LOOP with latch edge LATCH. */ @@ -666,15 +666,15 @@ form_subloop (struct loop *loop, edge latch) edge e, new_entry; struct loop *new_loop; - mfb_reis_set = pointer_set_create (); + mfb_reis_set = new hash_set; FOR_EACH_EDGE (e, ei, loop->header->preds) { if (e != latch) - pointer_set_insert (mfb_reis_set, e); + mfb_reis_set->add (e); } new_entry = make_forwarder_block (loop->header, mfb_redirect_edges_in_set, NULL); - pointer_set_destroy (mfb_reis_set); + delete mfb_reis_set; loop->header = new_entry->src; @@ -705,12 +705,12 @@ merge_latch_edges (struct loop *loop) if (dump_file) fprintf (dump_file, "Merged latch edges of loop %d\n", loop->num); - mfb_reis_set = pointer_set_create (); + mfb_reis_set = new hash_set; FOR_EACH_VEC_ELT (latches, i, e) - pointer_set_insert (mfb_reis_set, e); + mfb_reis_set->add (e); latch = make_forwarder_block (loop->header, mfb_redirect_edges_in_set, NULL); - pointer_set_destroy (mfb_reis_set); + delete mfb_reis_set; loop->header = latch->dest; loop->latch = latch->src; diff --git a/main/gcc/cgraph.c b/main/gcc/cgraph.c index 7923e9df638..2e6cb47e298 100644 --- a/main/gcc/cgraph.c +++ b/main/gcc/cgraph.c @@ -34,6 +34,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-inline.h" #include "langhooks.h" #include "hashtab.h" +#include "hash-set.h" #include "toplev.h" #include "flags.h" #include "debug.h" @@ -978,10 +979,15 @@ cgraph_node::create_indirect_edge (gimple call_stmt, int ecf_flags, edge->indirect_info->otr_token = otr_token; edge->indirect_info->otr_type = otr_type; edge->indirect_info->outer_type = context.outer_type; + edge->indirect_info->speculative_outer_type + = context.speculative_outer_type; edge->indirect_info->offset = context.offset; + edge->indirect_info->speculative_offset = context.speculative_offset; edge->indirect_info->maybe_in_construction = context.maybe_in_construction; edge->indirect_info->maybe_derived_type = context.maybe_derived_type; + edge->indirect_info->speculative_maybe_derived_type + = context.speculative_maybe_derived_type; } edge->next_callee = indirect_calls; @@ -2914,7 +2920,7 @@ cgraph_node::verify_node (void) { if (this_cfun->cfg) { - pointer_set_t *stmts = pointer_set_create (); + hash_set stmts; int i; struct ipa_ref *ref = NULL; @@ -2924,13 +2930,13 @@ cgraph_node::verify_node (void) { for (gsi = gsi_start_phis (this_block); !gsi_end_p (gsi); gsi_next (&gsi)) - pointer_set_insert (stmts, gsi_stmt (gsi)); + stmts.add (gsi_stmt (gsi)); for (gsi = gsi_start_bb (this_block); !gsi_end_p (gsi); gsi_next (&gsi)) { gimple stmt = gsi_stmt (gsi); - pointer_set_insert (stmts, stmt); + stmts.add (stmt); if (is_gimple_call (stmt)) { struct cgraph_edge *e = get_edge (stmt); @@ -2974,13 +2980,12 @@ cgraph_node::verify_node (void) } } for (i = 0; iterate_reference (i, ref); i++) - if (ref->stmt && !pointer_set_contains (stmts, ref->stmt)) + if (ref->stmt && !stmts.contains (ref->stmt)) { error ("reference to dead statement"); cgraph_debug_gimple_stmt (this_cfun, ref->stmt); error_found = true; } - pointer_set_destroy (stmts); } else /* No CFG available?! */ @@ -3086,12 +3091,9 @@ cgraph_node::get_body (void) data = lto_get_section_data (file_data, LTO_section_function_body, name, &len); if (!data) - { - debug (); fatal_error ("%s: section %s is missing", file_data->file_name, name); - } gcc_assert (DECL_STRUCT_FUNCTION (decl) == NULL); diff --git a/main/gcc/cgraph.h b/main/gcc/cgraph.h index c6c817dfd51..36186c05070 100644 --- a/main/gcc/cgraph.h +++ b/main/gcc/cgraph.h @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #ifndef GCC_CGRAPH_H #define GCC_CGRAPH_H +#include "hash-map.h" #include "is-a.h" #include "plugin-api.h" #include "vec.h" @@ -1212,7 +1213,7 @@ public: can appear in multiple sets. */ struct cgraph_node_set_def { - struct pointer_map_t *map; + hash_map *map; vec nodes; }; @@ -1225,7 +1226,7 @@ class varpool_node; can appear in multiple sets. */ struct varpool_node_set_def { - struct pointer_map_t * map; + hash_map * map; vec nodes; }; @@ -1251,11 +1252,11 @@ struct GTY(()) cgraph_indirect_call_info was actually used in the polymorphic resides within a larger structure. If agg_contents is set, the field contains the offset within the aggregate from which the address to call was loaded. */ - HOST_WIDE_INT offset; + HOST_WIDE_INT offset, speculative_offset; /* OBJ_TYPE_REF_TOKEN of a polymorphic call (if polymorphic is set). */ HOST_WIDE_INT otr_token; /* Type of the object from OBJ_TYPE_REF_OBJECT. */ - tree otr_type, outer_type; + tree otr_type, outer_type, speculative_outer_type; /* Index of the parameter that is called. */ int param_index; /* ECF flags determined from the caller. */ @@ -1278,6 +1279,7 @@ struct GTY(()) cgraph_indirect_call_info unsigned by_ref : 1; unsigned int maybe_in_construction : 1; unsigned int maybe_derived_type : 1; + unsigned int speculative_maybe_derived_type : 1; }; struct GTY((chain_next ("%h.next_caller"), chain_prev ("%h.prev_caller"))) cgraph_edge { @@ -1518,7 +1520,7 @@ enum cgraph_state }; extern enum cgraph_state cgraph_state; extern bool cgraph_function_flags_ready; -extern cgraph_node_set cgraph_new_nodes; +extern vec cgraph_new_nodes; extern GTY(()) struct asm_node *asm_nodes; extern GTY(()) int symtab_order; @@ -1717,24 +1719,7 @@ void record_references_in_initializer (tree, bool); /* In ipa.c */ bool symtab_remove_unreachable_nodes (bool, FILE *); -cgraph_node_set cgraph_node_set_new (void); -cgraph_node_set_iterator cgraph_node_set_find (cgraph_node_set, - cgraph_node *); -void cgraph_node_set_add (cgraph_node_set, cgraph_node *); -void cgraph_node_set_remove (cgraph_node_set, cgraph_node *); -void dump_cgraph_node_set (FILE *, cgraph_node_set); -void debug_cgraph_node_set (cgraph_node_set); -void free_cgraph_node_set (cgraph_node_set); void cgraph_build_static_cdtor (char which, tree body, int priority); - -varpool_node_set varpool_node_set_new (void); -varpool_node_set_iterator varpool_node_set_find (varpool_node_set, - varpool_node *); -void varpool_node_set_add (varpool_node_set, varpool_node *); -void varpool_node_set_remove (varpool_node_set, varpool_node *); -void dump_varpool_node_set (FILE *, varpool_node_set); -void debug_varpool_node_set (varpool_node_set); -void free_varpool_node_set (varpool_node_set); void ipa_discover_readonly_nonaddressable_vars (void); /* In predict.c */ @@ -2050,93 +2035,6 @@ cgraph_next_function_with_gimple_body (cgraph_node *node) /* Create a new static variable of type TYPE. */ tree add_new_static_var (tree type); -/* Return true if iterator CSI points to nothing. */ -static inline bool -csi_end_p (cgraph_node_set_iterator csi) -{ - return csi.index >= csi.set->nodes.length (); -} - -/* Advance iterator CSI. */ -static inline void -csi_next (cgraph_node_set_iterator *csi) -{ - csi->index++; -} - -/* Return the node pointed to by CSI. */ -static inline cgraph_node * -csi_node (cgraph_node_set_iterator csi) -{ - return csi.set->nodes[csi.index]; -} - -/* Return an iterator to the first node in SET. */ -static inline cgraph_node_set_iterator -csi_start (cgraph_node_set set) -{ - cgraph_node_set_iterator csi; - - csi.set = set; - csi.index = 0; - return csi; -} - -/* Return true if SET contains NODE. */ -static inline bool -cgraph_node_in_set_p (cgraph_node *node, cgraph_node_set set) -{ - cgraph_node_set_iterator csi; - csi = cgraph_node_set_find (set, node); - return !csi_end_p (csi); -} - -/* Return number of nodes in SET. */ -static inline size_t -cgraph_node_set_size (cgraph_node_set set) -{ - return set->nodes.length (); -} - -/* Return true if iterator VSI points to nothing. */ -static inline bool -vsi_end_p (varpool_node_set_iterator vsi) -{ - return vsi.index >= vsi.set->nodes.length (); -} - -/* Advance iterator VSI. */ -static inline void -vsi_next (varpool_node_set_iterator *vsi) -{ - vsi->index++; -} - -/* Return the node pointed to by VSI. */ -static inline varpool_node * -vsi_node (varpool_node_set_iterator vsi) -{ - return vsi.set->nodes[vsi.index]; -} - -/* Return an iterator to the first node in SET. */ -static inline varpool_node_set_iterator -vsi_start (varpool_node_set set) -{ - varpool_node_set_iterator vsi; - - vsi.set = set; - vsi.index = 0; - return vsi; -} - -/* Return number of nodes in SET. */ -static inline size_t -varpool_node_set_size (varpool_node_set set) -{ - return set->nodes.length (); -} - /* Uniquize all constants that appear in memory. Each constant in memory thus far output is recorded in `const_desc_table'. */ @@ -2154,20 +2052,6 @@ struct GTY(()) constant_descriptor_tree { hashval_t hash; }; -/* Return true if set is nonempty. */ -static inline bool -cgraph_node_set_nonempty_p (cgraph_node_set set) -{ - return !set->nodes.is_empty (); -} - -/* Return true if set is nonempty. */ -static inline bool -varpool_node_set_nonempty_p (varpool_node_set set) -{ - return !set->nodes.is_empty (); -} - /* Return true when function is only called directly or it has alias. i.e. it is not externally visible, address was not taken and it is not used in any other non-standard way. */ diff --git a/main/gcc/cgraphbuild.c b/main/gcc/cgraphbuild.c index 6aa84c9d9dd..f6867b50016 100644 --- a/main/gcc/cgraphbuild.c +++ b/main/gcc/cgraphbuild.c @@ -501,7 +501,6 @@ pass_build_cgraph_edges::execute (function *fun) { basic_block bb; struct cgraph_node *node = cgraph_node::get (current_function_decl); - struct pointer_set_t *visited_nodes = pointer_set_create (); gimple_stmt_iterator gsi; tree decl; unsigned ix; @@ -566,7 +565,6 @@ pass_build_cgraph_edges::execute (function *fun) varpool_node::finalize_decl (decl); record_eh_tables (node, fun); - pointer_set_destroy (visited_nodes); return 0; } @@ -585,15 +583,14 @@ make_pass_build_cgraph_edges (gcc::context *ctxt) void record_references_in_initializer (tree decl, bool only_vars) { - struct pointer_set_t *visited_nodes = pointer_set_create (); varpool_node *node = varpool_node::get_create (decl); + hash_set visited_nodes; struct record_reference_ctx ctx = {false, NULL}; ctx.varpool_node = node; ctx.only_vars = only_vars; walk_tree (&DECL_INITIAL (decl), record_reference, - &ctx, visited_nodes); - pointer_set_destroy (visited_nodes); + &ctx, &visited_nodes); } /* In LIPO mode, before tree_profiling, the call graph edge diff --git a/main/gcc/cgraphunit.c b/main/gcc/cgraphunit.c index 2a3d88b044a..a75078e1378 100644 --- a/main/gcc/cgraphunit.c +++ b/main/gcc/cgraphunit.c @@ -217,7 +217,7 @@ along with GCC; see the file COPYING3. If not see /* Queue of cgraph nodes scheduled to be added into cgraph. This is a secondary queue used during optimization to accommodate passes that may generate new functions that need to be optimized and expanded. */ -cgraph_node_set cgraph_new_nodes; +vec cgraph_new_nodes; static void expand_all_functions (void); static void mark_functions_to_output (void); @@ -309,17 +309,16 @@ void cgraph_process_new_functions (void) { tree fndecl; - struct cgraph_node *node; - cgraph_node_set_iterator csi; - if (!cgraph_new_nodes) + if (!cgraph_new_nodes.exists ()) return; + handle_alias_pairs (); /* Note that this queue may grow as its being processed, as the new functions may generate new ones. */ - for (csi = csi_start (cgraph_new_nodes); !csi_end_p (csi); csi_next (&csi)) + for (unsigned i = 0; i < cgraph_new_nodes.length (); i++) { - node = csi_node (csi); + cgraph_node *node = cgraph_new_nodes[i]; fndecl = node->decl; switch (cgraph_state) { @@ -366,8 +365,8 @@ cgraph_process_new_functions (void) break; } } - free_cgraph_node_set (cgraph_new_nodes); - cgraph_new_nodes = NULL; + + cgraph_new_nodes.release (); } /* As an GCC extension we allow redefinition of the function. The @@ -511,9 +510,7 @@ cgraph_node::add_new_function (tree fndecl, bool lowered) node = cgraph_node::get_create (fndecl); if (lowered) node->lowered = true; - if (!cgraph_new_nodes) - cgraph_new_nodes = cgraph_node_set_new (); - cgraph_node_set_add (cgraph_new_nodes, node); + cgraph_new_nodes.safe_push (node); break; case CGRAPH_STATE_IPA: @@ -539,9 +536,7 @@ cgraph_node::add_new_function (tree fndecl, bool lowered) } if (lowered) node->lowered = true; - if (!cgraph_new_nodes) - cgraph_new_nodes = cgraph_node_set_new (); - cgraph_node_set_add (cgraph_new_nodes, node); + cgraph_new_nodes.safe_push (node); break; case CGRAPH_STATE_FINISHED: @@ -854,7 +849,7 @@ varpool_node::finalize_decl (tree decl) avoid udplicate work. */ static void -walk_polymorphic_call_targets (pointer_set_t *reachable_call_targets, +walk_polymorphic_call_targets (hash_set *reachable_call_targets, struct cgraph_edge *edge) { unsigned int i; @@ -864,8 +859,7 @@ walk_polymorphic_call_targets (pointer_set_t *reachable_call_targets, = possible_polymorphic_call_targets (edge, &final, &cache_token); - if (!pointer_set_insert (reachable_call_targets, - cache_token)) + if (!reachable_call_targets->add (cache_token)) { if (cgraph_dump_file) dump_possible_polymorphic_call_targets @@ -945,7 +939,7 @@ analyze_functions (void) struct cgraph_node *first_handled = first_analyzed; static varpool_node *first_analyzed_var; varpool_node *first_handled_var = first_analyzed_var; - struct pointer_set_t *reachable_call_targets = pointer_set_create (); + hash_set reachable_call_targets; symtab_node *node; symtab_node *next; @@ -1045,7 +1039,7 @@ analyze_functions (void) { next = edge->next_callee; if (edge->indirect_info->polymorphic) - walk_polymorphic_call_targets (reachable_call_targets, + walk_polymorphic_call_targets (&reachable_call_targets, edge); } } @@ -1057,7 +1051,7 @@ analyze_functions (void) if (DECL_ABSTRACT_ORIGIN (decl)) { struct cgraph_node *origin_node - = cgraph_node::get (DECL_ABSTRACT_ORIGIN (decl)); + = cgraph_node::get_create (DECL_ABSTRACT_ORIGIN (decl)); origin_node->used_as_abstract_origin = true; } } @@ -1133,7 +1127,6 @@ analyze_functions (void) symtab_node::dump_table (cgraph_dump_file); } bitmap_obstack_release (NULL); - pointer_set_destroy (reachable_call_targets); ggc_collect (); /* Initialize assembler name hash, in particular we want to trigger C++ mangling and same body alias creation before we free DECL_ARGUMENTS diff --git a/main/gcc/common.opt b/main/gcc/common.opt index 213d39e1323..01e54a3894e 100644 --- a/main/gcc/common.opt +++ b/main/gcc/common.opt @@ -595,7 +595,7 @@ Wmissing-noreturn Common Alias(Wsuggest-attribute=noreturn) Wodr -Common Warning +Common Var(warn_odr_violations) Init(1) Warning Warn about some C++ One Definition Rule violations during link time optimization Woverflow @@ -622,6 +622,10 @@ Wpedantic Common Var(pedantic) Warning Issue warnings needed for strict compliance to the standard +Wreturn-local-addr +Common Var(warn_return_local_addr) Init(1) Warning +Warn about returning a pointer/reference to a local or temporary variable. + Wshadow Common Var(warn_shadow) Warning Warn when one local variable shadows another @@ -671,6 +675,14 @@ Wsuggest-attribute=noreturn Common Var(warn_suggest_attribute_noreturn) Warning Warn about functions which might be candidates for __attribute__((noreturn)) +Wsuggest-final-types +Common Var(warn_suggest_final_types) Warning +Warn about C++ polymorphic types where adding final keyword would improve code quality + +Wsuggest-final-methods +Common Var(warn_suggest_final_methods) Warning +Warn about C++ virtual methods where adding final keyword would improve code quality + Wsystem-headers Common Var(warn_system_headers) Warning Do not suppress warnings from system headers diff --git a/main/gcc/config.gcc b/main/gcc/config.gcc index 18c2c86dfcc..2f5756ae103 100644 --- a/main/gcc/config.gcc +++ b/main/gcc/config.gcc @@ -1189,6 +1189,12 @@ moxie-*-rtems*) tmake_file="${tmake_file} moxie/t-moxie" tm_file="moxie/moxie.h dbxelf.h elfos.h moxie/rtems.h rtems.h newlib-stdint.h" ;; +moxie-*-moxiebox*) + gas=yes + gnu_ld=yes + tm_file="${tm_file} dbxelf.h elfos.h moxie/moxiebox.h newlib-stdint.h" + tmake_file="${tmake_file} moxie/t-moxiebox" + ;; h8300-*-rtems*) tmake_file="${tmake_file} h8300/t-h8300 h8300/t-rtems" tm_file="h8300/h8300.h dbxelf.h elfos.h h8300/elf.h h8300/rtems.h rtems.h newlib-stdint.h" @@ -2279,7 +2285,7 @@ powerpc-*-rtems*) tmake_file="${tmake_file} rs6000/t-fprules rs6000/t-rtems rs6000/t-ppccomm" ;; powerpc*-*-linux*) - tm_file="${tm_file} dbxelf.h elfos.h freebsd-spec.h rs6000/sysv4.h" + tm_file="${tm_file} dbxelf.h elfos.h gnu-user.h freebsd-spec.h rs6000/sysv4.h" extra_options="${extra_options} rs6000/sysv4.opt" tmake_file="rs6000/t-fprules rs6000/t-ppcos ${tmake_file} rs6000/t-ppccomm" extra_objs="$extra_objs rs6000-linux.o" diff --git a/main/gcc/config.in b/main/gcc/config.in index 5e9e99ebd61..753de854a76 100644 --- a/main/gcc/config.in +++ b/main/gcc/config.in @@ -1474,6 +1474,12 @@ #endif +/* Define to 1 if you have the `popen' function. */ +#ifndef USED_FOR_TARGET +#undef HAVE_POPEN +#endif + + /* Define to 1 if you have the `putchar_unlocked' function. */ #ifndef USED_FOR_TARGET #undef HAVE_PUTCHAR_UNLOCKED diff --git a/main/gcc/config/aarch64/aarch64-builtins.c b/main/gcc/config/aarch64/aarch64-builtins.c index fee17ecf637..58db77e91c6 100644 --- a/main/gcc/config/aarch64/aarch64-builtins.c +++ b/main/gcc/config/aarch64/aarch64-builtins.c @@ -1383,6 +1383,20 @@ aarch64_gimple_fold_builtin (gimple_stmt_iterator *gsi) tree call = gimple_call_fn (stmt); tree fndecl; gimple new_stmt = NULL; + + /* The operations folded below are reduction operations. These are + defined to leave their result in the 0'th element (from the perspective + of GCC). The architectural instruction we are folding will leave the + result in the 0'th element (from the perspective of the architecture). + For big-endian systems, these perspectives are not aligned. + + It is therefore wrong to perform this fold on big-endian. There + are some tricks we could play with shuffling, but the mid-end is + inconsistent in the way it treats reduction operations, so we will + end up in difficulty. Until we fix the ambiguity - just bail out. */ + if (BYTES_BIG_ENDIAN) + return false; + if (call) { fndecl = gimple_call_fndecl (stmt); diff --git a/main/gcc/config/aarch64/aarch64-linux.h b/main/gcc/config/aarch64/aarch64-linux.h index ad58a37d97b..c6b5e9c9ff7 100644 --- a/main/gcc/config/aarch64/aarch64-linux.h +++ b/main/gcc/config/aarch64/aarch64-linux.h @@ -47,4 +47,6 @@ } \ while (0) +#define TARGET_ASM_FILE_END file_end_indicate_exec_stack + #endif /* GCC_AARCH64_LINUX_H */ diff --git a/main/gcc/config/aarch64/aarch64-protos.h b/main/gcc/config/aarch64/aarch64-protos.h index 53023bab4c3..cca3bc96af9 100644 --- a/main/gcc/config/aarch64/aarch64-protos.h +++ b/main/gcc/config/aarch64/aarch64-protos.h @@ -194,12 +194,15 @@ bool aarch64_modes_tieable_p (enum machine_mode mode1, bool aarch64_move_imm (HOST_WIDE_INT, enum machine_mode); bool aarch64_mov_operand_p (rtx, enum aarch64_symbol_context, enum machine_mode); +bool aarch64_offset_7bit_signed_scaled_p (enum machine_mode, HOST_WIDE_INT); char *aarch64_output_scalar_simd_mov_immediate (rtx, enum machine_mode); char *aarch64_output_simd_mov_immediate (rtx, enum machine_mode, unsigned); bool aarch64_pad_arg_upward (enum machine_mode, const_tree); bool aarch64_pad_reg_upward (enum machine_mode, const_tree, bool); bool aarch64_regno_ok_for_base_p (int, bool); bool aarch64_regno_ok_for_index_p (int, bool); +bool aarch64_simd_check_vect_par_cnst_half (rtx op, enum machine_mode mode, + bool high); bool aarch64_simd_imm_scalar_p (rtx x, enum machine_mode mode); bool aarch64_simd_imm_zero_p (rtx, enum machine_mode); bool aarch64_simd_scalar_immediate_valid_for_move (rtx, enum machine_mode); diff --git a/main/gcc/config/aarch64/aarch64-simd-builtins.def b/main/gcc/config/aarch64/aarch64-simd-builtins.def index 268432cc117..15cf4ca0027 100644 --- a/main/gcc/config/aarch64/aarch64-simd-builtins.def +++ b/main/gcc/config/aarch64/aarch64-simd-builtins.def @@ -47,8 +47,6 @@ VAR1 (UNOP, addp, 0, di) BUILTIN_VDQ_BHSI (UNOP, clz, 2) - BUILTIN_VALL (GETLANE, get_lane, 0) - VAR1 (GETLANE, get_lane, 0, di) BUILTIN_VALL (GETLANE, be_checked_get_lane, 0) VAR1 (REINTERP_SS, reinterpretdi, 0, v1df) @@ -74,7 +72,6 @@ VAR1 (REINTERP_PS, reinterpretv2si, 0, v1df) VAR1 (REINTERP_PS, reinterpretv2sf, 0, v1df) - BUILTIN_VDQ_I (BINOP, dup_lane, 0) /* Implemented by aarch64_qshl. */ BUILTIN_VSDQ_I (BINOP, sqshl, 0) BUILTIN_VSDQ_I (BINOP_UUS, uqshl, 0) diff --git a/main/gcc/config/aarch64/aarch64-simd.md b/main/gcc/config/aarch64/aarch64-simd.md index 6300b9b6c7a..0d4b37e53b7 100644 --- a/main/gcc/config/aarch64/aarch64-simd.md +++ b/main/gcc/config/aarch64/aarch64-simd.md @@ -1022,7 +1022,7 @@ (match_operand: 1 "register_operand" "w,r") (vec_select: (match_dup 0) - (match_operand:VQ 2 "vect_par_cnst_hi_half" ""))))] + (match_operand:VQ 2 "vect_par_cnst_lo_half" ""))))] "TARGET_SIMD && BYTES_BIG_ENDIAN" "@ ins\\t%0.d[1], %1.d[0] @@ -1035,7 +1035,7 @@ (match_operand: 1 "register_operand" "")] "TARGET_SIMD" { - rtx p = aarch64_simd_vect_par_cnst_half (mode, BYTES_BIG_ENDIAN); + rtx p = aarch64_simd_vect_par_cnst_half (mode, false); if (BYTES_BIG_ENDIAN) emit_insn (gen_aarch64_simd_move_hi_quad_be_ (operands[0], operands[1], p)); diff --git a/main/gcc/config/aarch64/aarch64.c b/main/gcc/config/aarch64/aarch64.c index ed80269d55f..7e135a19ada 100644 --- a/main/gcc/config/aarch64/aarch64.c +++ b/main/gcc/config/aarch64/aarch64.c @@ -2006,10 +2006,10 @@ aarch64_gen_loadwb_pair (enum machine_mode mode, rtx base, rtx reg, rtx reg2, { case DImode: return gen_loadwb_pairdi_di (base, base, reg, reg2, GEN_INT (adjustment), - GEN_INT (adjustment + UNITS_PER_WORD)); + GEN_INT (UNITS_PER_WORD)); case DFmode: return gen_loadwb_pairdf_di (base, base, reg, reg2, GEN_INT (adjustment), - GEN_INT (adjustment + UNITS_PER_WORD)); + GEN_INT (UNITS_PER_WORD)); default: gcc_unreachable (); } @@ -3193,8 +3193,8 @@ aarch64_classify_index (struct aarch64_address_info *info, rtx x, return false; } -static inline bool -offset_7bit_signed_scaled_p (enum machine_mode mode, HOST_WIDE_INT offset) +bool +aarch64_offset_7bit_signed_scaled_p (enum machine_mode mode, HOST_WIDE_INT offset) { return (offset >= -64 * GET_MODE_SIZE (mode) && offset < 64 * GET_MODE_SIZE (mode) @@ -3248,6 +3248,21 @@ aarch64_classify_address (struct aarch64_address_info *info, case PLUS: op0 = XEXP (x, 0); op1 = XEXP (x, 1); + + if (! strict_p + && GET_CODE (op0) == REG + && (op0 == virtual_stack_vars_rtx + || op0 == frame_pointer_rtx + || op0 == arg_pointer_rtx) + && GET_CODE (op1) == CONST_INT) + { + info->type = ADDRESS_REG_IMM; + info->base = op0; + info->offset = op1; + + return true; + } + if (GET_MODE_SIZE (mode) != 0 && CONST_INT_P (op1) && aarch64_base_register_rtx_p (op0, strict_p)) @@ -3266,12 +3281,12 @@ aarch64_classify_address (struct aarch64_address_info *info, We conservatively require an offset representable in either mode. */ if (mode == TImode || mode == TFmode) - return (offset_7bit_signed_scaled_p (mode, offset) + return (aarch64_offset_7bit_signed_scaled_p (mode, offset) && offset_9bit_signed_unscaled_p (mode, offset)); if (outer_code == PARALLEL) return ((GET_MODE_SIZE (mode) == 4 || GET_MODE_SIZE (mode) == 8) - && offset_7bit_signed_scaled_p (mode, offset)); + && aarch64_offset_7bit_signed_scaled_p (mode, offset)); else return (offset_9bit_signed_unscaled_p (mode, offset) || offset_12bit_unsigned_scaled_p (mode, offset)); @@ -3326,12 +3341,12 @@ aarch64_classify_address (struct aarch64_address_info *info, We conservatively require an offset representable in either mode. */ if (mode == TImode || mode == TFmode) - return (offset_7bit_signed_scaled_p (mode, offset) + return (aarch64_offset_7bit_signed_scaled_p (mode, offset) && offset_9bit_signed_unscaled_p (mode, offset)); if (outer_code == PARALLEL) return ((GET_MODE_SIZE (mode) == 4 || GET_MODE_SIZE (mode) == 8) - && offset_7bit_signed_scaled_p (mode, offset)); + && aarch64_offset_7bit_signed_scaled_p (mode, offset)); else return offset_9bit_signed_unscaled_p (mode, offset); } @@ -7900,23 +7915,81 @@ aarch64_simd_scalar_immediate_valid_for_move (rtx op, enum machine_mode mode) return aarch64_simd_valid_immediate (op_v, vmode, false, NULL); } -/* Construct and return a PARALLEL RTX vector. */ +/* Construct and return a PARALLEL RTX vector with elements numbering the + lanes of either the high (HIGH == TRUE) or low (HIGH == FALSE) half of + the vector - from the perspective of the architecture. This does not + line up with GCC's perspective on lane numbers, so we end up with + different masks depending on our target endian-ness. The diagram + below may help. We must draw the distinction when building masks + which select one half of the vector. An instruction selecting + architectural low-lanes for a big-endian target, must be described using + a mask selecting GCC high-lanes. + + Big-Endian Little-Endian + +GCC 0 1 2 3 3 2 1 0 + | x | x | x | x | | x | x | x | x | +Architecture 3 2 1 0 3 2 1 0 + +Low Mask: { 2, 3 } { 0, 1 } +High Mask: { 0, 1 } { 2, 3 } +*/ + rtx aarch64_simd_vect_par_cnst_half (enum machine_mode mode, bool high) { int nunits = GET_MODE_NUNITS (mode); rtvec v = rtvec_alloc (nunits / 2); - int base = high ? nunits / 2 : 0; + int high_base = nunits / 2; + int low_base = 0; + int base; rtx t1; int i; - for (i=0; i < nunits / 2; i++) + if (BYTES_BIG_ENDIAN) + base = high ? low_base : high_base; + else + base = high ? high_base : low_base; + + for (i = 0; i < nunits / 2; i++) RTVEC_ELT (v, i) = GEN_INT (base + i); t1 = gen_rtx_PARALLEL (mode, v); return t1; } +/* Check OP for validity as a PARALLEL RTX vector with elements + numbering the lanes of either the high (HIGH == TRUE) or low lanes, + from the perspective of the architecture. See the diagram above + aarch64_simd_vect_par_cnst_half for more details. */ + +bool +aarch64_simd_check_vect_par_cnst_half (rtx op, enum machine_mode mode, + bool high) +{ + rtx ideal = aarch64_simd_vect_par_cnst_half (mode, high); + HOST_WIDE_INT count_op = XVECLEN (op, 0); + HOST_WIDE_INT count_ideal = XVECLEN (ideal, 0); + int i = 0; + + if (!VECTOR_MODE_P (mode)) + return false; + + if (count_op != count_ideal) + return false; + + for (i = 0; i < count_ideal; i++) + { + rtx elt_op = XVECEXP (op, 0, i); + rtx elt_ideal = XVECEXP (ideal, 0, i); + + if (GET_CODE (elt_op) != CONST_INT + || INTVAL (elt_ideal) != INTVAL (elt_op)) + return false; + } + return true; +} + /* Bounds-check lanes. Ensure OPERAND lies between LOW (inclusive) and HIGH (exclusive). */ void diff --git a/main/gcc/config/aarch64/aarch64.md b/main/gcc/config/aarch64/aarch64.md index 85bf2a7a531..eac4664861c 100644 --- a/main/gcc/config/aarch64/aarch64.md +++ b/main/gcc/config/aarch64/aarch64.md @@ -1016,20 +1016,19 @@ [(set_attr "type" "neon_store1_2reg")] ) -;; Load pair with writeback. This is primarily used in function epilogues -;; when restoring [fp,lr] +;; Load pair with post-index writeback. This is primarily used in function +;; epilogues. (define_insn "loadwb_pair_" [(parallel [(set (match_operand:P 0 "register_operand" "=k") (plus:P (match_operand:P 1 "register_operand" "0") - (match_operand:P 4 "const_int_operand" "n"))) + (match_operand:P 4 "aarch64_mem_pair_offset" "n"))) (set (match_operand:GPI 2 "register_operand" "=r") - (mem:GPI (plus:P (match_dup 1) - (match_dup 4)))) + (mem:GPI (match_dup 1))) (set (match_operand:GPI 3 "register_operand" "=r") (mem:GPI (plus:P (match_dup 1) (match_operand:P 5 "const_int_operand" "n"))))])] - "INTVAL (operands[5]) == INTVAL (operands[4]) + GET_MODE_SIZE (mode)" + "INTVAL (operands[5]) == GET_MODE_SIZE (mode)" "ldp\\t%2, %3, [%1], %4" [(set_attr "type" "load2")] ) @@ -1038,25 +1037,24 @@ [(parallel [(set (match_operand:P 0 "register_operand" "=k") (plus:P (match_operand:P 1 "register_operand" "0") - (match_operand:P 4 "const_int_operand" "n"))) + (match_operand:P 4 "aarch64_mem_pair_offset" "n"))) (set (match_operand:GPF 2 "register_operand" "=w") - (mem:GPF (plus:P (match_dup 1) - (match_dup 4)))) + (mem:GPF (match_dup 1))) (set (match_operand:GPF 3 "register_operand" "=w") (mem:GPF (plus:P (match_dup 1) (match_operand:P 5 "const_int_operand" "n"))))])] - "INTVAL (operands[5]) == INTVAL (operands[4]) + GET_MODE_SIZE (mode)" + "INTVAL (operands[5]) == GET_MODE_SIZE (mode)" "ldp\\t%2, %3, [%1], %4" [(set_attr "type" "neon_load1_2reg")] ) -;; Store pair with writeback. This is primarily used in function prologues -;; when saving [fp,lr] +;; Store pair with pre-index writeback. This is primarily used in function +;; prologues. (define_insn "storewb_pair_" [(parallel [(set (match_operand:P 0 "register_operand" "=&k") (plus:P (match_operand:P 1 "register_operand" "0") - (match_operand:P 4 "const_int_operand" "n"))) + (match_operand:P 4 "aarch64_mem_pair_offset" "n"))) (set (mem:GPI (plus:P (match_dup 0) (match_dup 4))) (match_operand:GPI 2 "register_operand" "r")) @@ -1072,7 +1070,7 @@ [(parallel [(set (match_operand:P 0 "register_operand" "=&k") (plus:P (match_operand:P 1 "register_operand" "0") - (match_operand:P 4 "const_int_operand" "n"))) + (match_operand:P 4 "aarch64_mem_pair_offset" "n"))) (set (mem:GPF (plus:P (match_dup 0) (match_dup 4))) (match_operand:GPF 2 "register_operand" "w")) @@ -3390,7 +3388,7 @@ [(set (zero_extract:GPI (match_operand:GPI 0 "register_operand" "+r") (match_operand 1 "const_int_operand" "n") (const_int 0)) - (zero_extract:GPI (match_operand:GPI 2 "register_operand" "+r") + (zero_extract:GPI (match_operand:GPI 2 "register_operand" "r") (match_dup 1) (match_operand 3 "const_int_operand" "n")))] "!(UINTVAL (operands[1]) == 0 diff --git a/main/gcc/config/aarch64/arm_neon.h b/main/gcc/config/aarch64/arm_neon.h index 66968e8d198..7e6aba77267 100644 --- a/main/gcc/config/aarch64/arm_neon.h +++ b/main/gcc/config/aarch64/arm_neon.h @@ -9233,56 +9233,6 @@ vpadd_f32 (float32x2_t a, float32x2_t b) return result; } -__extension__ static __inline int8x8_t __attribute__ ((__always_inline__)) -vpadd_s8 (int8x8_t __a, int8x8_t __b) -{ - return __builtin_aarch64_addpv8qi (__a, __b); -} - -__extension__ static __inline int16x4_t __attribute__ ((__always_inline__)) -vpadd_s16 (int16x4_t __a, int16x4_t __b) -{ - return __builtin_aarch64_addpv4hi (__a, __b); -} - -__extension__ static __inline int32x2_t __attribute__ ((__always_inline__)) -vpadd_s32 (int32x2_t __a, int32x2_t __b) -{ - return __builtin_aarch64_addpv2si (__a, __b); -} - -__extension__ static __inline uint8x8_t __attribute__ ((__always_inline__)) -vpadd_u8 (uint8x8_t __a, uint8x8_t __b) -{ - return (uint8x8_t) __builtin_aarch64_addpv8qi ((int8x8_t) __a, - (int8x8_t) __b); -} - -__extension__ static __inline uint16x4_t __attribute__ ((__always_inline__)) -vpadd_u16 (uint16x4_t __a, uint16x4_t __b) -{ - return (uint16x4_t) __builtin_aarch64_addpv4hi ((int16x4_t) __a, - (int16x4_t) __b); -} - -__extension__ static __inline uint32x2_t __attribute__ ((__always_inline__)) -vpadd_u32 (uint32x2_t __a, uint32x2_t __b) -{ - return (uint32x2_t) __builtin_aarch64_addpv2si ((int32x2_t) __a, - (int32x2_t) __b); -} - -__extension__ static __inline float64_t __attribute__ ((__always_inline__)) -vpaddd_f64 (float64x2_t a) -{ - float64_t result; - __asm__ ("faddp %d0,%1.2d" - : "=w"(result) - : "w"(a) - : /* No clobbers */); - return result; -} - __extension__ static __inline int16x4_t __attribute__ ((__always_inline__)) vpaddl_s8 (int8x8_t a) { @@ -12563,12 +12513,6 @@ vaddlv_u32 (uint32x2_t a) return result; } -__extension__ static __inline int64_t __attribute__ ((__always_inline__)) -vpaddd_s64 (int64x2_t __a) -{ - return __builtin_aarch64_addpdi (__a); -} - __extension__ static __inline int16x4_t __attribute__ ((__always_inline__)) vqdmulh_laneq_s16 (int16x4_t __a, int16x8_t __b, const int __c) { @@ -19230,6 +19174,65 @@ vnegq_s64 (int64x2_t __a) return -__a; } +/* vpadd */ + +__extension__ static __inline int8x8_t __attribute__ ((__always_inline__)) +vpadd_s8 (int8x8_t __a, int8x8_t __b) +{ + return __builtin_aarch64_addpv8qi (__a, __b); +} + +__extension__ static __inline int16x4_t __attribute__ ((__always_inline__)) +vpadd_s16 (int16x4_t __a, int16x4_t __b) +{ + return __builtin_aarch64_addpv4hi (__a, __b); +} + +__extension__ static __inline int32x2_t __attribute__ ((__always_inline__)) +vpadd_s32 (int32x2_t __a, int32x2_t __b) +{ + return __builtin_aarch64_addpv2si (__a, __b); +} + +__extension__ static __inline uint8x8_t __attribute__ ((__always_inline__)) +vpadd_u8 (uint8x8_t __a, uint8x8_t __b) +{ + return (uint8x8_t) __builtin_aarch64_addpv8qi ((int8x8_t) __a, + (int8x8_t) __b); +} + +__extension__ static __inline uint16x4_t __attribute__ ((__always_inline__)) +vpadd_u16 (uint16x4_t __a, uint16x4_t __b) +{ + return (uint16x4_t) __builtin_aarch64_addpv4hi ((int16x4_t) __a, + (int16x4_t) __b); +} + +__extension__ static __inline uint32x2_t __attribute__ ((__always_inline__)) +vpadd_u32 (uint32x2_t __a, uint32x2_t __b) +{ + return (uint32x2_t) __builtin_aarch64_addpv2si ((int32x2_t) __a, + (int32x2_t) __b); +} + +__extension__ static __inline float64_t __attribute__ ((__always_inline__)) +vpaddd_f64 (float64x2_t __a) +{ + return vgetq_lane_f64 (__builtin_aarch64_reduc_splus_v2df (__a), 0); +} + +__extension__ static __inline int64_t __attribute__ ((__always_inline__)) +vpaddd_s64 (int64x2_t __a) +{ + return __builtin_aarch64_addpdi (__a); +} + +__extension__ static __inline uint64_t __attribute__ ((__always_inline__)) +vpaddd_u64 (uint64x2_t __a) +{ + return __builtin_aarch64_addpdi ((int64x2_t) __a); +} + /* vqabs */ __extension__ static __inline int64x2_t __attribute__ ((__always_inline__)) diff --git a/main/gcc/config/aarch64/predicates.md b/main/gcc/config/aarch64/predicates.md index 2702a3c8d83..3dd83caf907 100644 --- a/main/gcc/config/aarch64/predicates.md +++ b/main/gcc/config/aarch64/predicates.md @@ -123,6 +123,10 @@ (match_test "INTVAL (op) != 0 && (unsigned) exact_log2 (INTVAL (op)) < 64"))) +(define_predicate "aarch64_mem_pair_offset" + (and (match_code "const_int") + (match_test "aarch64_offset_7bit_signed_scaled_p (mode, INTVAL (op))"))) + (define_predicate "aarch64_mem_pair_operand" (and (match_code "mem") (match_test "aarch64_legitimate_address_p (mode, XEXP (op, 0), PARALLEL, @@ -207,62 +211,15 @@ (define_special_predicate "vect_par_cnst_hi_half" (match_code "parallel") { - HOST_WIDE_INT count = XVECLEN (op, 0); - int nunits = GET_MODE_NUNITS (mode); - int i; - - if (count < 1 - || count != nunits / 2) - return false; - - if (!VECTOR_MODE_P (mode)) - return false; - - for (i = 0; i < count; i++) - { - rtx elt = XVECEXP (op, 0, i); - int val; - - if (GET_CODE (elt) != CONST_INT) - return false; - - val = INTVAL (elt); - if (val != (nunits / 2) + i) - return false; - } - return true; + return aarch64_simd_check_vect_par_cnst_half (op, mode, true); }) (define_special_predicate "vect_par_cnst_lo_half" (match_code "parallel") { - HOST_WIDE_INT count = XVECLEN (op, 0); - int nunits = GET_MODE_NUNITS (mode); - int i; - - if (count < 1 - || count != nunits / 2) - return false; - - if (!VECTOR_MODE_P (mode)) - return false; - - for (i = 0; i < count; i++) - { - rtx elt = XVECEXP (op, 0, i); - int val; - - if (GET_CODE (elt) != CONST_INT) - return false; - - val = INTVAL (elt); - if (val != i) - return false; - } - return true; + return aarch64_simd_check_vect_par_cnst_half (op, mode, false); }) - (define_special_predicate "aarch64_simd_lshift_imm" (match_code "const_vector") { diff --git a/main/gcc/config/alpha/elf.h b/main/gcc/config/alpha/elf.h index 5a6803abab8..ec90fca2ef5 100644 --- a/main/gcc/config/alpha/elf.h +++ b/main/gcc/config/alpha/elf.h @@ -126,6 +126,10 @@ do { \ "%{Ofast|ffast-math|funsafe-math-optimizations:crtfastmath.o%s} \ %{shared|pie:crtendS.o%s;:crtend.o%s} crtn.o%s" +/* This variable should be set to 'true' if the target ABI requires + unwinding tables even when exceptions are not used. */ +#define TARGET_UNWIND_TABLES_DEFAULT true + /* Select a format to encode pointers in exception handling data. CODE is 0 for data, 1 for code labels, 2 for function pointers. GLOBAL is true if the symbol may be affected by dynamic relocations. diff --git a/main/gcc/config/arm/arm.c b/main/gcc/config/arm/arm.c index 7e62ba5b9eb..4c8b2c2ff97 100644 --- a/main/gcc/config/arm/arm.c +++ b/main/gcc/config/arm/arm.c @@ -20803,7 +20803,7 @@ arm_get_frame_offsets (void) || !(TARGET_LDRD && current_tune->prefer_ldrd_strd))) { reg = 3; - if (!(TARGET_LDRD && current_tune->prefer_ldrd_strd)) + if (!TARGET_THUMB2) prefer_callee_reg_p = true; } if (reg == -1 diff --git a/main/gcc/config/arm/neon.md b/main/gcc/config/arm/neon.md index 1fc4dcd8275..dc364eeb64e 100644 --- a/main/gcc/config/arm/neon.md +++ b/main/gcc/config/arm/neon.md @@ -1041,7 +1041,9 @@ } else { - if (CONST_INT_P (operands[2]) && INTVAL (operands[2]) == 1) + if (CONST_INT_P (operands[2]) && INTVAL (operands[2]) == 1 + && (!reg_overlap_mentioned_p (operands[0], operands[1]) + || REGNO (operands[0]) == REGNO (operands[1]))) /* This clobbers CC. */ emit_insn (gen_arm_ashldi3_1bit (operands[0], operands[1])); else @@ -1141,7 +1143,9 @@ } else { - if (CONST_INT_P (operands[2]) && INTVAL (operands[2]) == 1) + if (CONST_INT_P (operands[2]) && INTVAL (operands[2]) == 1 + && (!reg_overlap_mentioned_p (operands[0], operands[1]) + || REGNO (operands[0]) == REGNO (operands[1]))) /* This clobbers CC. */ emit_insn (gen_arm_di3_1bit (operands[0], operands[1])); else diff --git a/main/gcc/config/avr/avr-c.c b/main/gcc/config/avr/avr-c.c index c6a2f1f9471..c1ba134deee 100644 --- a/main/gcc/config/avr/avr-c.c +++ b/main/gcc/config/avr/avr-c.c @@ -299,7 +299,11 @@ avr_cpu_cpp_builtins (struct cpp_reader *pfile) if (avr_current_arch->macro) cpp_define_formatted (pfile, "__AVR_ARCH__=%s", avr_current_arch->macro); if (avr_current_device->macro) - cpp_define (pfile, avr_current_device->macro); + { + cpp_define (pfile, avr_current_device->macro); + cpp_define_formatted (pfile, "__AVR_DEVICE_NAME__=%s", + avr_current_device->name); + } if (AVR_HAVE_RAMPD) cpp_define (pfile, "__AVR_HAVE_RAMPD__"); if (AVR_HAVE_RAMPX) cpp_define (pfile, "__AVR_HAVE_RAMPX__"); if (AVR_HAVE_RAMPY) cpp_define (pfile, "__AVR_HAVE_RAMPY__"); diff --git a/main/gcc/config/i386/driver-i386.c b/main/gcc/config/i386/driver-i386.c index 1c6385fe4f5..f82fd0b2801 100644 --- a/main/gcc/config/i386/driver-i386.c +++ b/main/gcc/config/i386/driver-i386.c @@ -432,7 +432,8 @@ const char *host_detect_local_cpu (int argc, const char **argv) model = (eax >> 4) & 0x0f; family = (eax >> 8) & 0x0f; - if (vendor == signature_INTEL_ebx) + if (vendor == signature_INTEL_ebx + || vendor == signature_AMD_ebx) { unsigned int extended_model, extended_family; @@ -576,7 +577,7 @@ const char *host_detect_local_cpu (int argc, const char **argv) if (name == signature_NSC_ebx) processor = PROCESSOR_GEODE; - else if (has_movbe) + else if (has_movbe && family == 22) processor = PROCESSOR_BTVER2; else if (has_avx2) processor = PROCESSOR_BDVER4; diff --git a/main/gcc/config/i386/i386.c b/main/gcc/config/i386/i386.c index cf05553268a..f272c8bb53b 100644 --- a/main/gcc/config/i386/i386.c +++ b/main/gcc/config/i386/i386.c @@ -3268,12 +3268,13 @@ ix86_option_override_internal (bool main_args_p, | PTA_FMA | PTA_PRFCHW | PTA_FXSR | PTA_XSAVE | PTA_XSAVEOPT | PTA_FSGSBASE}, {"bdver4", PROCESSOR_BDVER4, CPU_BDVER4, - PTA_64BIT | PTA_MMX | PTA_SSE | PTA_SSE2 | PTA_SSE3 - | PTA_SSE4A | PTA_CX16 | PTA_ABM | PTA_SSSE3 | PTA_SSE4_1 - | PTA_SSE4_2 | PTA_AES | PTA_PCLMUL | PTA_AVX | PTA_AVX2 + PTA_64BIT | PTA_MMX | PTA_SSE | PTA_SSE2 | PTA_SSE3 + | PTA_SSE4A | PTA_CX16 | PTA_ABM | PTA_SSSE3 | PTA_SSE4_1 + | PTA_SSE4_2 | PTA_AES | PTA_PCLMUL | PTA_AVX | PTA_AVX2 | PTA_FMA4 | PTA_XOP | PTA_LWP | PTA_BMI | PTA_BMI2 | PTA_TBM | PTA_F16C | PTA_FMA | PTA_PRFCHW | PTA_FXSR - | PTA_XSAVE | PTA_XSAVEOPT | PTA_FSGSBASE}, + | PTA_XSAVE | PTA_XSAVEOPT | PTA_FSGSBASE | PTA_RDRND + | PTA_MOVBE}, {"btver1", PROCESSOR_BTVER1, CPU_GENERIC, PTA_64BIT | PTA_MMX | PTA_SSE | PTA_SSE2 | PTA_SSE3 | PTA_SSSE3 | PTA_SSE4A |PTA_ABM | PTA_CX16 | PTA_PRFCHW @@ -8019,7 +8020,7 @@ ix86_libcall_value (enum machine_mode mode) /* Return true iff type is returned in memory. */ static bool -ix86_return_in_memory (const_tree type, const_tree fntype) +ix86_return_in_memory (const_tree type, const_tree fntype ATTRIBUTE_UNUSED) { #ifdef SUBTARGET_RETURN_IN_MEMORY return SUBTARGET_RETURN_IN_MEMORY (type, fntype); @@ -25310,7 +25311,7 @@ assign_386_stack_local (enum machine_mode mode, enum ix86_stack_slot n) s->next = ix86_stack_locals; ix86_stack_locals = s; - return validize_mem (s->rtl); + return validize_mem (copy_rtx (s->rtl)); } static void @@ -26057,6 +26058,9 @@ ix86_macro_fusion_pair_p (rtx condgen, rtx condjmp) rtx compare_set = NULL_RTX, test_if, cond; rtx alu_set = NULL_RTX, addr = NULL_RTX; + if (!any_condjump_p (condjmp)) + return false; + if (get_attr_type (condgen) != TYPE_TEST && get_attr_type (condgen) != TYPE_ICMP && get_attr_type (condgen) != TYPE_INCDEC diff --git a/main/gcc/config/mips/mips.c b/main/gcc/config/mips/mips.c index 3876da8d1ba..d8654c4479a 100644 --- a/main/gcc/config/mips/mips.c +++ b/main/gcc/config/mips/mips.c @@ -2171,15 +2171,6 @@ mips_symbol_insns (enum mips_symbol_type type, enum machine_mode mode) return mips_symbol_insns_1 (type, mode) * (TARGET_MIPS16 ? 2 : 1); } -/* A for_each_rtx callback. Stop the search if *X references a - thread-local symbol. */ - -static int -mips_tls_symbol_ref_1 (rtx *x, void *data ATTRIBUTE_UNUSED) -{ - return mips_tls_symbol_p (*x); -} - /* Implement TARGET_CANNOT_FORCE_CONST_MEM. */ static bool @@ -2223,7 +2214,7 @@ mips_cannot_force_const_mem (enum machine_mode mode, rtx x) } /* TLS symbols must be computed by mips_legitimize_move. */ - if (for_each_rtx (&x, &mips_tls_symbol_ref_1, NULL)) + if (tls_referenced_p (x)) return true; return false; diff --git a/main/gcc/config/mips/mips.h b/main/gcc/config/mips/mips.h index 1164b4b1808..8d7a09fb7a9 100644 --- a/main/gcc/config/mips/mips.h +++ b/main/gcc/config/mips/mips.h @@ -1266,6 +1266,12 @@ struct mips_cpu_info { /* By default, turn on GDB extensions. */ #define DEFAULT_GDB_EXTENSIONS 1 +/* Registers may have a prefix which can be ignored when matching + user asm and register definitions. */ +#ifndef REGISTER_PREFIX +#define REGISTER_PREFIX "$" +#endif + /* Local compiler-generated symbols must have a prefix that the assembler understands. By default, this is $, although some targets (e.g., NetBSD-ELF) need to override this. */ diff --git a/main/gcc/config/moxie/moxiebox.h b/main/gcc/config/moxie/moxiebox.h new file mode 100644 index 00000000000..0f75e5dfb3e --- /dev/null +++ b/main/gcc/config/moxie/moxiebox.h @@ -0,0 +1,47 @@ +/* Definitions for the moxiebox. + Copyright (C) 2014 Free Software Foundation, Inc. + Contributed by Anthony Green (green@moxielogic.com) + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +/* Target OS preprocessor built-ins. */ +#define TARGET_OS_CPP_BUILTINS() \ + do \ + { \ + builtin_define_std ("moxie"); \ + builtin_define ("__moxiebox__"); \ + builtin_assert ("system=moxiebox"); \ + } \ + while (0) + +#undef LIB_SPEC +#define LIB_SPEC \ +"%{!T*:-Tmoxiebox.ld} \ + %{!nostdlib: --start-group -lsandboxrt -lc -lgcc --end-group }" + +#undef LINK_SPEC +#define LINK_SPEC "%{h*} %{v:-V} -EL -Bstatic" + +#undef ASM_SPEC +#define ASM_SPEC "-EL" + +#undef MULTILIB_DEFAULTS + +#undef SIZE_TYPE +#undef PTRDIFF_TYPE +#undef WCHAR_TYPE +#undef WCHAR_TYPE_SIZE diff --git a/main/gcc/config/pa/pa-protos.h b/main/gcc/config/pa/pa-protos.h index 2659dcdf06a..e72abeadd9b 100644 --- a/main/gcc/config/pa/pa-protos.h +++ b/main/gcc/config/pa/pa-protos.h @@ -54,7 +54,6 @@ extern void pa_output_global_address (FILE *, rtx, int); extern void pa_print_operand (FILE *, rtx, int); extern void pa_encode_label (rtx); extern int pa_symbolic_expression_p (rtx); -extern bool pa_tls_referenced_p (rtx); extern int pa_adjust_insn_length (rtx, int); extern int pa_fmpyaddoperands (rtx *); extern int pa_fmpysuboperands (rtx *); diff --git a/main/gcc/config/pa/pa.c b/main/gcc/config/pa/pa.c index e13674143fe..d52d52f071d 100644 --- a/main/gcc/config/pa/pa.c +++ b/main/gcc/config/pa/pa.c @@ -1037,7 +1037,7 @@ hppa_legitimize_address (rtx x, rtx oldx ATTRIBUTE_UNUSED, && !REG_POINTER (XEXP (x, 1))) return gen_rtx_PLUS (Pmode, XEXP (x, 1), XEXP (x, 0)); - if (pa_tls_referenced_p (x)) + if (tls_referenced_p (x)) return legitimize_tls_address (x); else if (flag_pic) return legitimize_pic_address (x, mode, gen_reg_rtx (Pmode)); @@ -1542,31 +1542,12 @@ force_mode (enum machine_mode mode, rtx orig) return gen_rtx_REG (mode, REGNO (orig)); } -/* Return 1 if *X is a thread-local symbol. */ - -static int -pa_tls_symbol_ref_1 (rtx *x, void *data ATTRIBUTE_UNUSED) -{ - return PA_SYMBOL_REF_TLS_P (*x); -} - -/* Return 1 if X contains a thread-local symbol. */ - -bool -pa_tls_referenced_p (rtx x) -{ - if (!TARGET_HAVE_TLS) - return false; - - return for_each_rtx (&x, &pa_tls_symbol_ref_1, 0); -} - /* Implement TARGET_CANNOT_FORCE_CONST_MEM. */ static bool pa_cannot_force_const_mem (enum machine_mode mode ATTRIBUTE_UNUSED, rtx x) { - return pa_tls_referenced_p (x); + return tls_referenced_p (x); } /* Emit insns to move operands[1] into operands[0]. @@ -1921,7 +1902,7 @@ pa_emit_move_sequence (rtx *operands, enum machine_mode mode, rtx scratch_reg) || (GET_CODE (operand1) == HIGH && symbolic_operand (XEXP (operand1, 0), mode)) || function_label_operand (operand1, VOIDmode) - || pa_tls_referenced_p (operand1)) + || tls_referenced_p (operand1)) { int ishighonly = 0; @@ -2081,7 +2062,7 @@ pa_emit_move_sequence (rtx *operands, enum machine_mode mode, rtx scratch_reg) } return 1; } - else if (pa_tls_referenced_p (operand1)) + else if (tls_referenced_p (operand1)) { rtx tmp = operand1; rtx addend = NULL; @@ -10293,7 +10274,7 @@ pa_legitimate_constant_p (enum machine_mode mode, rtx x) /* TLS_MODEL_GLOBAL_DYNAMIC and TLS_MODEL_LOCAL_DYNAMIC are not legitimate constants. The other variants can't be handled by the move patterns after reload starts. */ - if (pa_tls_referenced_p (x)) + if (tls_referenced_p (x)) return false; if (TARGET_64BIT && GET_CODE (x) == CONST_DOUBLE) diff --git a/main/gcc/config/pa/pa.h b/main/gcc/config/pa/pa.h index 3f9f06bb6f2..7292d6a42bf 100644 --- a/main/gcc/config/pa/pa.h +++ b/main/gcc/config/pa/pa.h @@ -797,7 +797,7 @@ extern int may_call_alloca; ((GET_CODE (X) == LABEL_REF \ || (GET_CODE (X) == SYMBOL_REF && !SYMBOL_REF_TLS_MODEL (X)) \ || GET_CODE (X) == CONST_INT \ - || (GET_CODE (X) == CONST && !pa_tls_referenced_p (X)) \ + || (GET_CODE (X) == CONST && !tls_referenced_p (X)) \ || GET_CODE (X) == HIGH) \ && (reload_in_progress || reload_completed \ || ! pa_symbolic_expression_p (X))) diff --git a/main/gcc/config/rs6000/freebsd64.h b/main/gcc/config/rs6000/freebsd64.h index 4f678f6f4d1..1f3ef199e86 100644 --- a/main/gcc/config/rs6000/freebsd64.h +++ b/main/gcc/config/rs6000/freebsd64.h @@ -367,7 +367,7 @@ extern int dot_symbols; /* PowerPC64 Linux word-aligns FP doubles when -malign-power is given. */ #undef ADJUST_FIELD_ALIGN #define ADJUST_FIELD_ALIGN(FIELD, COMPUTED) \ - ((TARGET_ALTIVEC && TREE_CODE (TREE_TYPE (FIELD)) == VECTOR_TYPE) \ + (rs6000_special_adjust_field_align_p ((FIELD), (COMPUTED)) \ ? 128 \ : (TARGET_64BIT \ && TARGET_ALIGN_NATURAL == 0 \ diff --git a/main/gcc/config/rs6000/linux.h b/main/gcc/config/rs6000/linux.h index 1f4579f3378..7c83f1e78ef 100644 --- a/main/gcc/config/rs6000/linux.h +++ b/main/gcc/config/rs6000/linux.h @@ -56,12 +56,6 @@ #undef CPP_OS_DEFAULT_SPEC #define CPP_OS_DEFAULT_SPEC "%(cpp_os_linux)" -/* The GNU C++ standard library currently requires _GNU_SOURCE being - defined on glibc-based systems. This temporary hack accomplishes this, - it should go away as soon as libstdc++-v3 has a real fix. */ -#undef CPLUSPLUS_CPP_SPEC -#define CPLUSPLUS_CPP_SPEC "-D_GNU_SOURCE %(cpp)" - #undef LINK_SHLIB_SPEC #define LINK_SHLIB_SPEC "%{shared:-shared} %{!shared: %{static:-static}}" @@ -98,22 +92,6 @@ %{rdynamic:-export-dynamic} \ -dynamic-linker " GNU_USER_DYNAMIC_LINKER "}}" -#define LINK_GCC_C_SEQUENCE_SPEC \ - "%{static:--start-group} %G %L %{static:--end-group}%{!static:%G}" - -/* Use --as-needed -lgcc_s for eh support. */ -#ifdef HAVE_LD_AS_NEEDED -#define USE_LD_AS_NEEDED 1 -#endif - -/* Override rs6000.h definition. */ -#undef ASM_APP_ON -#define ASM_APP_ON "#APP\n" - -/* Override rs6000.h definition. */ -#undef ASM_APP_OFF -#define ASM_APP_OFF "#NO_APP\n" - /* For backward compatibility, we must continue to use the AIX structure return convention. */ #undef DRAFT_V4_STRUCT_RET @@ -129,8 +107,6 @@ #define RELOCATABLE_NEEDS_FIXUP \ (rs6000_isa_flags & rs6000_isa_flags_explicit & OPTION_MASK_RELOCATABLE) -#define TARGET_POSIX_IO - #ifdef TARGET_LIBC_PROVIDES_SSP /* ppc32 glibc provides __stack_chk_guard in -0x7008(2). */ #define TARGET_THREAD_SSP_OFFSET -0x7008 diff --git a/main/gcc/config/rs6000/linux64.h b/main/gcc/config/rs6000/linux64.h index 52c233b7ded..d7e2b844795 100644 --- a/main/gcc/config/rs6000/linux64.h +++ b/main/gcc/config/rs6000/linux64.h @@ -246,7 +246,7 @@ extern int dot_symbols; /* PowerPC64 Linux word-aligns FP doubles when -malign-power is given. */ #undef ADJUST_FIELD_ALIGN #define ADJUST_FIELD_ALIGN(FIELD, COMPUTED) \ - ((TARGET_ALTIVEC && TREE_CODE (TREE_TYPE (FIELD)) == VECTOR_TYPE) \ + (rs6000_special_adjust_field_align_p ((FIELD), (COMPUTED)) \ ? 128 \ : (TARGET_64BIT \ && TARGET_ALIGN_NATURAL == 0 \ @@ -343,12 +343,6 @@ extern int dot_symbols; #undef CPP_OS_DEFAULT_SPEC #define CPP_OS_DEFAULT_SPEC "%(cpp_os_linux)" -/* The GNU C++ standard library currently requires _GNU_SOURCE being - defined on glibc-based systems. This temporary hack accomplishes this, - it should go away as soon as libstdc++-v3 has a real fix. */ -#undef CPLUSPLUS_CPP_SPEC -#define CPLUSPLUS_CPP_SPEC "-D_GNU_SOURCE %(cpp)" - #undef LINK_SHLIB_SPEC #define LINK_SHLIB_SPEC "%{shared:-shared} %{!shared: %{static:-static}}" @@ -440,14 +434,6 @@ extern int dot_symbols; #undef WCHAR_TYPE_SIZE #define WCHAR_TYPE_SIZE 32 -/* Override rs6000.h definition. */ -#undef ASM_APP_ON -#define ASM_APP_ON "#APP\n" - -/* Override rs6000.h definition. */ -#undef ASM_APP_OFF -#define ASM_APP_OFF "#NO_APP\n" - #undef RS6000_MCOUNT #define RS6000_MCOUNT "_mcount" @@ -547,16 +533,6 @@ extern int dot_symbols; #undef DRAFT_V4_STRUCT_RET #define DRAFT_V4_STRUCT_RET (!TARGET_64BIT) -#define TARGET_POSIX_IO - -#define LINK_GCC_C_SEQUENCE_SPEC \ - "%{static:--start-group} %G %L %{static:--end-group}%{!static:%G}" - -/* Use --as-needed -lgcc_s for eh support. */ -#ifdef HAVE_LD_AS_NEEDED -#define USE_LD_AS_NEEDED 1 -#endif - #ifdef TARGET_LIBC_PROVIDES_SSP /* ppc32 glibc provides __stack_chk_guard in -0x7008(2), ppc64 glibc provides it at -0x7010(13). */ diff --git a/main/gcc/config/rs6000/rs6000-protos.h b/main/gcc/config/rs6000/rs6000-protos.h index 83581ac0bfb..82564db5c90 100644 --- a/main/gcc/config/rs6000/rs6000-protos.h +++ b/main/gcc/config/rs6000/rs6000-protos.h @@ -155,6 +155,7 @@ extern void rs6000_split_logical (rtx [], enum rtx_code, bool, bool, bool, rtx); #ifdef TREE_CODE extern unsigned int rs6000_data_alignment (tree, unsigned int, enum data_align); +extern bool rs6000_special_adjust_field_align_p (tree, unsigned int); extern unsigned int rs6000_special_round_type_align (tree, unsigned int, unsigned int); extern unsigned int darwin_rs6000_special_round_type_align (tree, unsigned int, diff --git a/main/gcc/config/rs6000/rs6000.c b/main/gcc/config/rs6000/rs6000.c index 02fc5d90492..d088ff6acd2 100644 --- a/main/gcc/config/rs6000/rs6000.c +++ b/main/gcc/config/rs6000/rs6000.c @@ -1101,7 +1101,6 @@ static void is_altivec_return_reg (rtx, void *); int easy_vector_constant (rtx, enum machine_mode); static rtx rs6000_debug_legitimize_address (rtx, rtx, enum machine_mode); static rtx rs6000_legitimize_tls_address (rtx, enum tls_model); -static int rs6000_tls_symbol_ref_1 (rtx *, void *); static int rs6000_get_some_local_dynamic_name_1 (rtx *, void *); static rtx rs6000_darwin64_record_arg (CUMULATIVE_ARGS *, const_tree, bool, bool); @@ -1222,7 +1221,12 @@ char rs6000_reg_names[][8] = /* Soft frame pointer. */ "sfp", /* HTM SPR registers. */ - "tfhar", "tfiar", "texasr" + "tfhar", "tfiar", "texasr", + /* SPE High registers. */ + "0", "1", "2", "3", "4", "5", "6", "7", + "8", "9", "10", "11", "12", "13", "14", "15", + "16", "17", "18", "19", "20", "21", "22", "23", + "24", "25", "26", "27", "28", "29", "30", "31" }; #ifdef TARGET_REGNAMES @@ -1250,7 +1254,12 @@ static const char alt_reg_names[][8] = /* Soft frame pointer. */ "sfp", /* HTM SPR registers. */ - "tfhar", "tfiar", "texasr" + "tfhar", "tfiar", "texasr", + /* SPE High registers. */ + "%rh0", "%rh1", "%rh2", "%rh3", "%rh4", "%rh5", "%rh6", "%rh7", + "%rh8", "%rh9", "%rh10", "%r11", "%rh12", "%rh13", "%rh14", "%rh15", + "%rh16", "%rh17", "%rh18", "%rh19", "%rh20", "%rh21", "%rh22", "%rh23", + "%rh24", "%rh25", "%rh26", "%rh27", "%rh28", "%rh29", "%rh30", "%rh31" }; #endif @@ -5880,6 +5889,32 @@ rs6000_data_alignment (tree type, unsigned int align, enum data_align how) return align; } +/* Previous GCC releases forced all vector types to have 16-byte alignment. */ + +bool +rs6000_special_adjust_field_align_p (tree field, unsigned int computed) +{ + if (TARGET_ALTIVEC && TREE_CODE (TREE_TYPE (field)) == VECTOR_TYPE) + { + if (computed != 128) + { + static bool warned; + if (!warned && warn_psabi) + { + warned = true; + inform (input_location, + "the layout of aggregates containing vectors with" + " %d-byte alignment has changed in GCC 4.10", + computed / BITS_PER_UNIT); + } + } + /* In current GCC there is no special case. */ + return false; + } + + return false; +} + /* AIX increases natural record alignment to doubleword if the first field is an FP double while the FP fields remain word aligned. */ @@ -7228,17 +7263,6 @@ rs6000_legitimize_tls_address (rtx addr, enum tls_model model) return dest; } -/* Return 1 if X contains a thread-local symbol. */ - -static bool -rs6000_tls_referenced_p (rtx x) -{ - if (! TARGET_HAVE_TLS) - return false; - - return for_each_rtx (&x, &rs6000_tls_symbol_ref_1, 0); -} - /* Implement TARGET_CANNOT_FORCE_CONST_MEM. */ static bool @@ -7256,16 +7280,7 @@ rs6000_cannot_force_const_mem (enum machine_mode mode ATTRIBUTE_UNUSED, rtx x) return true; /* Do not place an ELF TLS symbol in the constant pool. */ - return TARGET_ELF && rs6000_tls_referenced_p (x); -} - -/* Return 1 if *X is a thread-local symbol. This is the same as - rs6000_tls_symbol_ref except for the type of the unused argument. */ - -static int -rs6000_tls_symbol_ref_1 (rtx *x, void *data ATTRIBUTE_UNUSED) -{ - return RS6000_SYMBOL_REF_TLS_P (*x); + return TARGET_ELF && tls_referenced_p (x); } /* Return true iff the given SYMBOL_REF refers to a constant pool entry @@ -8214,7 +8229,7 @@ rs6000_emit_move (rtx dest, rtx source, enum machine_mode mode) /* Recognize the case where operand[1] is a reference to thread-local data and load its address to a register. */ - if (rs6000_tls_referenced_p (operands[1])) + if (tls_referenced_p (operands[1])) { enum tls_model model; rtx tmp = operands[1]; @@ -9184,14 +9199,48 @@ rs6000_function_arg_boundary (enum machine_mode mode, const_tree type) || (type && TREE_CODE (type) == VECTOR_TYPE && int_size_in_bytes (type) >= 16)) return 128; - else if (((TARGET_MACHO && rs6000_darwin64_abi) - || DEFAULT_ABI == ABI_ELFv2 - || (DEFAULT_ABI == ABI_AIX && !rs6000_compat_align_parm)) - && mode == BLKmode - && type && TYPE_ALIGN (type) > 64) + + /* Aggregate types that need > 8 byte alignment are quadword-aligned + in the parameter area in the ELFv2 ABI, and in the AIX ABI unless + -mcompat-align-parm is used. */ + if (((DEFAULT_ABI == ABI_AIX && !rs6000_compat_align_parm) + || DEFAULT_ABI == ABI_ELFv2) + && type && TYPE_ALIGN (type) > 64) + { + /* "Aggregate" means any AGGREGATE_TYPE except for single-element + or homogeneous float/vector aggregates here. We already handled + vector aggregates above, but still need to check for float here. */ + bool aggregate_p = (AGGREGATE_TYPE_P (type) + && !SCALAR_FLOAT_MODE_P (elt_mode)); + + /* We used to check for BLKmode instead of the above aggregate type + check. Warn when this results in any difference to the ABI. */ + if (aggregate_p != (mode == BLKmode)) + { + static bool warned; + if (!warned && warn_psabi) + { + warned = true; + inform (input_location, + "the ABI of passing aggregates with %d-byte alignment" + " has changed in GCC 4.10", + (int) TYPE_ALIGN (type) / BITS_PER_UNIT); + } + } + + if (aggregate_p) + return 128; + } + + /* Similar for the Darwin64 ABI. Note that for historical reasons we + implement the "aggregate type" check as a BLKmode check here; this + means certain aggregate types are in fact not aligned. */ + if (TARGET_MACHO && rs6000_darwin64_abi + && mode == BLKmode + && type && TYPE_ALIGN (type) > 64) return 128; - else - return PARM_BOUNDARY; + + return PARM_BOUNDARY; } /* The offset in words to the start of the parameter save area. */ @@ -10229,6 +10278,7 @@ rs6000_function_arg (cumulative_args_t cum_v, enum machine_mode mode, rtx r, off; int i, k = 0; unsigned long n_fpreg = (GET_MODE_SIZE (elt_mode) + 7) >> 3; + int fpr_words; /* Do we also need to pass this argument in the parameter save area? */ @@ -10257,6 +10307,47 @@ rs6000_function_arg (cumulative_args_t cum_v, enum machine_mode mode, rvec[k++] = gen_rtx_EXPR_LIST (VOIDmode, r, off); } + /* If there were not enough FPRs to hold the argument, the rest + usually goes into memory. However, if the current position + is still within the register parameter area, a portion may + actually have to go into GPRs. + + Note that it may happen that the portion of the argument + passed in the first "half" of the first GPR was already + passed in the last FPR as well. + + For unnamed arguments, we already set up GPRs to cover the + whole argument in rs6000_psave_function_arg, so there is + nothing further to do at this point. */ + fpr_words = (i * GET_MODE_SIZE (elt_mode)) / (TARGET_32BIT ? 4 : 8); + if (i < n_elts && align_words + fpr_words < GP_ARG_NUM_REG + && cum->nargs_prototype > 0) + { + static bool warned; + + enum machine_mode rmode = TARGET_32BIT ? SImode : DImode; + int n_words = rs6000_arg_size (mode, type); + + align_words += fpr_words; + n_words -= fpr_words; + + do + { + r = gen_rtx_REG (rmode, GP_ARG_MIN_REG + align_words); + off = GEN_INT (fpr_words++ * GET_MODE_SIZE (rmode)); + rvec[k++] = gen_rtx_EXPR_LIST (VOIDmode, r, off); + } + while (++align_words < GP_ARG_NUM_REG && --n_words != 0); + + if (!warned && warn_psabi) + { + warned = true; + inform (input_location, + "the ABI of passing homogeneous float aggregates" + " has changed in GCC 4.10"); + } + } + return rs6000_finish_function_arg (mode, rvec, k); } else if (align_words < GP_ARG_NUM_REG) @@ -10332,8 +10423,23 @@ rs6000_arg_partial_bytes (cumulative_args_t cum_v, enum machine_mode mode, /* Otherwise, we pass in FPRs only. Check for partial copies. */ passed_in_gprs = false; if (cum->fregno + n_elts * n_fpreg > FP_ARG_MAX_REG + 1) - ret = ((FP_ARG_MAX_REG + 1 - cum->fregno) - * MIN (8, GET_MODE_SIZE (elt_mode))); + { + /* Compute number of bytes / words passed in FPRs. If there + is still space available in the register parameter area + *after* that amount, a part of the argument will be passed + in GPRs. In that case, the total amount passed in any + registers is equal to the amount that would have been passed + in GPRs if everything were passed there, so we fall back to + the GPR code below to compute the appropriate value. */ + int fpr = ((FP_ARG_MAX_REG + 1 - cum->fregno) + * MIN (8, GET_MODE_SIZE (elt_mode))); + int fpr_words = fpr / (TARGET_32BIT ? 4 : 8); + + if (align_words + fpr_words < GP_ARG_NUM_REG) + passed_in_gprs = true; + else + ret = fpr; + } } if (passed_in_gprs @@ -31315,13 +31421,13 @@ rs6000_dwarf_register_span (rtx reg) { if (BYTES_BIG_ENDIAN) { - parts[2 * i] = gen_rtx_REG (SImode, regno + 1200); + parts[2 * i] = gen_rtx_REG (SImode, regno + FIRST_SPE_HIGH_REGNO); parts[2 * i + 1] = gen_rtx_REG (SImode, regno); } else { parts[2 * i] = gen_rtx_REG (SImode, regno); - parts[2 * i + 1] = gen_rtx_REG (SImode, regno + 1200); + parts[2 * i + 1] = gen_rtx_REG (SImode, regno + FIRST_SPE_HIGH_REGNO); } } @@ -31341,11 +31447,11 @@ rs6000_init_dwarf_reg_sizes_extra (tree address) rtx mem = gen_rtx_MEM (BLKmode, addr); rtx value = gen_int_mode (4, mode); - for (i = 1201; i < 1232; i++) + for (i = FIRST_SPE_HIGH_REGNO; i < LAST_SPE_HIGH_REGNO+1; i++) { - int column = DWARF_REG_TO_UNWIND_COLUMN (i); - HOST_WIDE_INT offset - = DWARF_FRAME_REGNUM (column) * GET_MODE_SIZE (mode); + int column = DWARF_REG_TO_UNWIND_COLUMN + (DWARF2_FRAME_REG_OUT (DWARF_FRAME_REGNUM (i), true)); + HOST_WIDE_INT offset = column * GET_MODE_SIZE (mode); emit_move_insn (adjust_address (mem, mode, offset), value); } @@ -31364,9 +31470,9 @@ rs6000_init_dwarf_reg_sizes_extra (tree address) for (i = FIRST_ALTIVEC_REGNO; i < LAST_ALTIVEC_REGNO+1; i++) { - int column = DWARF_REG_TO_UNWIND_COLUMN (i); - HOST_WIDE_INT offset - = DWARF_FRAME_REGNUM (column) * GET_MODE_SIZE (mode); + int column = DWARF_REG_TO_UNWIND_COLUMN + (DWARF2_FRAME_REG_OUT (DWARF_FRAME_REGNUM (i), true)); + HOST_WIDE_INT offset = column * GET_MODE_SIZE (mode); emit_move_insn (adjust_address (mem, mode, offset), value); } @@ -31398,9 +31504,8 @@ rs6000_dbx_register_number (unsigned int regno) return 99; if (regno == SPEFSCR_REGNO) return 612; - /* SPE high reg number. We get these values of regno from - rs6000_dwarf_register_span. */ - gcc_assert (regno >= 1200 && regno < 1232); + if (SPE_HIGH_REGNO_P (regno)) + return regno - FIRST_SPE_HIGH_REGNO + 1200; return regno; } @@ -32324,7 +32429,7 @@ rs6000_address_for_altivec (rtx x) static bool rs6000_legitimate_constant_p (enum machine_mode mode, rtx x) { - if (TARGET_ELF && rs6000_tls_referenced_p (x)) + if (TARGET_ELF && tls_referenced_p (x)) return false; return ((GET_CODE (x) != CONST_DOUBLE && GET_CODE (x) != CONST_VECTOR) diff --git a/main/gcc/config/rs6000/rs6000.h b/main/gcc/config/rs6000/rs6000.h index 569ae2d3f27..d8a68ba3d91 100644 --- a/main/gcc/config/rs6000/rs6000.h +++ b/main/gcc/config/rs6000/rs6000.h @@ -930,35 +930,36 @@ enum data_align { align_abi, align_opt, align_both }; The 3 HTM registers aren't also included in DWARF_FRAME_REGISTERS. */ -#define FIRST_PSEUDO_REGISTER 117 +#define FIRST_PSEUDO_REGISTER 149 /* This must be included for pre gcc 3.0 glibc compatibility. */ #define PRE_GCC3_DWARF_FRAME_REGISTERS 77 -/* Add 32 dwarf columns for synthetic SPE registers. */ -#define DWARF_FRAME_REGISTERS ((FIRST_PSEUDO_REGISTER - 4) + 32) +/* True if register is an SPE High register. */ +#define SPE_HIGH_REGNO_P(N) \ + ((N) >= FIRST_SPE_HIGH_REGNO && (N) <= LAST_SPE_HIGH_REGNO) + +/* SPE high registers added as hard regs. + The sfp register and 3 HTM registers + aren't included in DWARF_FRAME_REGISTERS. */ +#define DWARF_FRAME_REGISTERS (FIRST_PSEUDO_REGISTER - 4) /* The SPE has an additional 32 synthetic registers, with DWARF debug info numbering for these registers starting at 1200. While eh_frame register numbering need not be the same as the debug info numbering, - we choose to number these regs for eh_frame at 1200 too. This allows - future versions of the rs6000 backend to add hard registers and - continue to use the gcc hard register numbering for eh_frame. If the - extra SPE registers in eh_frame were numbered starting from the - current value of FIRST_PSEUDO_REGISTER, then if FIRST_PSEUDO_REGISTER - changed we'd need to introduce a mapping in DWARF_FRAME_REGNUM to - avoid invalidating older SPE eh_frame info. + we choose to number these regs for eh_frame at 1200 too. We must map them here to avoid huge unwinder tables mostly consisting of unused space. */ #define DWARF_REG_TO_UNWIND_COLUMN(r) \ - ((r) > 1200 ? ((r) - 1200 + (DWARF_FRAME_REGISTERS - 32)) : (r)) + ((r) >= 1200 ? ((r) - 1200 + (DWARF_FRAME_REGISTERS - 32)) : (r)) /* Use standard DWARF numbering for DWARF debugging information. */ #define DBX_REGISTER_NUMBER(REGNO) rs6000_dbx_register_number (REGNO) /* Use gcc hard register numbering for eh_frame. */ -#define DWARF_FRAME_REGNUM(REGNO) (REGNO) +#define DWARF_FRAME_REGNUM(REGNO) \ + (SPE_HIGH_REGNO_P (REGNO) ? ((REGNO) - FIRST_SPE_HIGH_REGNO + 1200) : (REGNO)) /* Map register numbers held in the call frame info that gcc has collected using DWARF_FRAME_REGNUM to those that should be output in @@ -990,7 +991,10 @@ enum data_align { align_abi, align_opt, align_both }; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 1, 1 \ - , 1, 1, 1, 1, 1, 1 \ + , 1, 1, 1, 1, 1, 1, \ + /* SPE High registers. */ \ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, \ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 \ } /* 1 for registers not available across function calls. @@ -1010,7 +1014,10 @@ enum data_align { align_abi, align_opt, align_both }; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 1, 1 \ - , 1, 1, 1, 1, 1, 1 \ + , 1, 1, 1, 1, 1, 1, \ + /* SPE High registers. */ \ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, \ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 \ } /* Like `CALL_USED_REGISTERS' except this macro doesn't require that @@ -1029,7 +1036,10 @@ enum data_align { align_abi, align_opt, align_both }; 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ 0, 0 \ - , 0, 0, 0, 0, 0, 0 \ + , 0, 0, 0, 0, 0, 0, \ + /* SPE High registers. */ \ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, \ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 \ } #define TOTAL_ALTIVEC_REGS (LAST_ALTIVEC_REGNO - FIRST_ALTIVEC_REGNO + 1) @@ -1113,7 +1123,10 @@ enum data_align { align_abi, align_opt, align_both }; 96, 95, 94, 93, 92, 91, \ 108, 107, 106, 105, 104, 103, 102, 101, 100, 99, 98, 97, \ 109, 110, \ - 111, 112, 113, 114, 115, 116 \ + 111, 112, 113, 114, 115, 116, \ + 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128, \ + 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, \ + 141, 142, 143, 144, 145, 146, 147, 148 \ } /* True if register is floating-point. */ @@ -1348,6 +1361,7 @@ enum reg_class CR_REGS, NON_FLOAT_REGS, CA_REGS, + SPE_HIGH_REGS, ALL_REGS, LIM_REG_CLASSES }; @@ -1379,6 +1393,7 @@ enum reg_class "CR_REGS", \ "NON_FLOAT_REGS", \ "CA_REGS", \ + "SPE_HIGH_REGS", \ "ALL_REGS" \ } @@ -1386,30 +1401,54 @@ enum reg_class This is an initializer for a vector of HARD_REG_SET of length N_REG_CLASSES. */ -#define REG_CLASS_CONTENTS \ -{ \ - { 0x00000000, 0x00000000, 0x00000000, 0x00000000 }, /* NO_REGS */ \ - { 0xfffffffe, 0x00000000, 0x00000008, 0x00020000 }, /* BASE_REGS */ \ - { 0xffffffff, 0x00000000, 0x00000008, 0x00020000 }, /* GENERAL_REGS */ \ - { 0x00000000, 0xffffffff, 0x00000000, 0x00000000 }, /* FLOAT_REGS */ \ - { 0x00000000, 0x00000000, 0xffffe000, 0x00001fff }, /* ALTIVEC_REGS */ \ - { 0x00000000, 0xffffffff, 0xffffe000, 0x00001fff }, /* VSX_REGS */ \ - { 0x00000000, 0x00000000, 0x00000000, 0x00002000 }, /* VRSAVE_REGS */ \ - { 0x00000000, 0x00000000, 0x00000000, 0x00004000 }, /* VSCR_REGS */ \ - { 0x00000000, 0x00000000, 0x00000000, 0x00008000 }, /* SPE_ACC_REGS */ \ - { 0x00000000, 0x00000000, 0x00000000, 0x00010000 }, /* SPEFSCR_REGS */ \ - { 0x00000000, 0x00000000, 0x00000000, 0x00040000 }, /* SPR_REGS */ \ - { 0xffffffff, 0xffffffff, 0x00000008, 0x00020000 }, /* NON_SPECIAL_REGS */ \ - { 0x00000000, 0x00000000, 0x00000002, 0x00000000 }, /* LINK_REGS */ \ - { 0x00000000, 0x00000000, 0x00000004, 0x00000000 }, /* CTR_REGS */ \ - { 0x00000000, 0x00000000, 0x00000006, 0x00000000 }, /* LINK_OR_CTR_REGS */ \ - { 0x00000000, 0x00000000, 0x00000006, 0x00002000 }, /* SPECIAL_REGS */ \ - { 0xffffffff, 0x00000000, 0x0000000e, 0x00022000 }, /* SPEC_OR_GEN_REGS */ \ - { 0x00000000, 0x00000000, 0x00000010, 0x00000000 }, /* CR0_REGS */ \ - { 0x00000000, 0x00000000, 0x00000ff0, 0x00000000 }, /* CR_REGS */ \ - { 0xffffffff, 0x00000000, 0x00000ffe, 0x00020000 }, /* NON_FLOAT_REGS */ \ - { 0x00000000, 0x00000000, 0x00001000, 0x00000000 }, /* CA_REGS */ \ - { 0xffffffff, 0xffffffff, 0xfffffffe, 0x0007ffff } /* ALL_REGS */ \ +#define REG_CLASS_CONTENTS \ +{ \ + /* NO_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0x00000000, 0x00000000 }, \ + /* BASE_REGS. */ \ + { 0xfffffffe, 0x00000000, 0x00000008, 0x00020000, 0x00000000 }, \ + /* GENERAL_REGS. */ \ + { 0xffffffff, 0x00000000, 0x00000008, 0x00020000, 0x00000000 }, \ + /* FLOAT_REGS. */ \ + { 0x00000000, 0xffffffff, 0x00000000, 0x00000000, 0x00000000 }, \ + /* ALTIVEC_REGS. */ \ + { 0x00000000, 0x00000000, 0xffffe000, 0x00001fff, 0x00000000 }, \ + /* VSX_REGS. */ \ + { 0x00000000, 0xffffffff, 0xffffe000, 0x00001fff, 0x00000000 }, \ + /* VRSAVE_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0x00002000, 0x00000000 }, \ + /* VSCR_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0x00004000, 0x00000000 }, \ + /* SPE_ACC_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0x00008000, 0x00000000 }, \ + /* SPEFSCR_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0x00010000, 0x00000000 }, \ + /* SPR_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0x00040000, 0x00000000 }, \ + /* NON_SPECIAL_REGS. */ \ + { 0xffffffff, 0xffffffff, 0x00000008, 0x00020000, 0x00000000 }, \ + /* LINK_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000002, 0x00000000, 0x00000000 }, \ + /* CTR_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000004, 0x00000000, 0x00000000 }, \ + /* LINK_OR_CTR_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000006, 0x00000000, 0x00000000 }, \ + /* SPECIAL_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000006, 0x00002000, 0x00000000 }, \ + /* SPEC_OR_GEN_REGS. */ \ + { 0xffffffff, 0x00000000, 0x0000000e, 0x00022000, 0x00000000 }, \ + /* CR0_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000010, 0x00000000, 0x00000000 }, \ + /* CR_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000ff0, 0x00000000, 0x00000000 }, \ + /* NON_FLOAT_REGS. */ \ + { 0xffffffff, 0x00000000, 0x00000ffe, 0x00020000, 0x00000000 }, \ + /* CA_REGS. */ \ + { 0x00000000, 0x00000000, 0x00001000, 0x00000000, 0x00000000 }, \ + /* SPE_HIGH_REGS. */ \ + { 0x00000000, 0x00000000, 0x00000000, 0xffe00000, 0x001fffff }, \ + /* ALL_REGS. */ \ + { 0xffffffff, 0xffffffff, 0xfffffffe, 0xffe7ffff, 0x001fffff } \ } /* The same information, inverted: @@ -2348,6 +2387,39 @@ extern char rs6000_reg_names[][8]; /* register names (0 vs. %r0). */ &rs6000_reg_names[114][0], /* tfhar */ \ &rs6000_reg_names[115][0], /* tfiar */ \ &rs6000_reg_names[116][0], /* texasr */ \ + \ + &rs6000_reg_names[117][0], /* SPE rh0. */ \ + &rs6000_reg_names[118][0], /* SPE rh1. */ \ + &rs6000_reg_names[119][0], /* SPE rh2. */ \ + &rs6000_reg_names[120][0], /* SPE rh3. */ \ + &rs6000_reg_names[121][0], /* SPE rh4. */ \ + &rs6000_reg_names[122][0], /* SPE rh5. */ \ + &rs6000_reg_names[123][0], /* SPE rh6. */ \ + &rs6000_reg_names[124][0], /* SPE rh7. */ \ + &rs6000_reg_names[125][0], /* SPE rh8. */ \ + &rs6000_reg_names[126][0], /* SPE rh9. */ \ + &rs6000_reg_names[127][0], /* SPE rh10. */ \ + &rs6000_reg_names[128][0], /* SPE rh11. */ \ + &rs6000_reg_names[129][0], /* SPE rh12. */ \ + &rs6000_reg_names[130][0], /* SPE rh13. */ \ + &rs6000_reg_names[131][0], /* SPE rh14. */ \ + &rs6000_reg_names[132][0], /* SPE rh15. */ \ + &rs6000_reg_names[133][0], /* SPE rh16. */ \ + &rs6000_reg_names[134][0], /* SPE rh17. */ \ + &rs6000_reg_names[135][0], /* SPE rh18. */ \ + &rs6000_reg_names[136][0], /* SPE rh19. */ \ + &rs6000_reg_names[137][0], /* SPE rh20. */ \ + &rs6000_reg_names[138][0], /* SPE rh21. */ \ + &rs6000_reg_names[139][0], /* SPE rh22. */ \ + &rs6000_reg_names[140][0], /* SPE rh22. */ \ + &rs6000_reg_names[141][0], /* SPE rh24. */ \ + &rs6000_reg_names[142][0], /* SPE rh25. */ \ + &rs6000_reg_names[143][0], /* SPE rh26. */ \ + &rs6000_reg_names[144][0], /* SPE rh27. */ \ + &rs6000_reg_names[145][0], /* SPE rh28. */ \ + &rs6000_reg_names[146][0], /* SPE rh29. */ \ + &rs6000_reg_names[147][0], /* SPE rh30. */ \ + &rs6000_reg_names[148][0], /* SPE rh31. */ \ } /* Table of additional register names to use in user input. */ @@ -2403,7 +2475,17 @@ extern char rs6000_reg_names[][8]; /* register names (0 vs. %r0). */ {"vs56", 101},{"vs57", 102},{"vs58", 103},{"vs59", 104}, \ {"vs60", 105},{"vs61", 106},{"vs62", 107},{"vs63", 108}, \ /* Transactional Memory Facility (HTM) Registers. */ \ - {"tfhar", 114}, {"tfiar", 115}, {"texasr", 116} } + {"tfhar", 114}, {"tfiar", 115}, {"texasr", 116}, \ + /* SPE high registers. */ \ + {"rh0", 117}, {"rh1", 118}, {"rh2", 119}, {"rh3", 120}, \ + {"rh4", 121}, {"rh5", 122}, {"rh6", 123}, {"rh7", 124}, \ + {"rh8", 125}, {"rh9", 126}, {"rh10", 127}, {"rh11", 128}, \ + {"rh12", 129}, {"rh13", 130}, {"rh14", 131}, {"rh15", 132}, \ + {"rh16", 133}, {"rh17", 134}, {"rh18", 135}, {"rh19", 136}, \ + {"rh20", 137}, {"rh21", 138}, {"rh22", 139}, {"rh23", 140}, \ + {"rh24", 141}, {"rh25", 142}, {"rh26", 143}, {"rh27", 144}, \ + {"rh28", 145}, {"rh29", 146}, {"rh30", 147}, {"rh31", 148}, \ +} /* This is how to output an element of a case-vector that is relative. */ diff --git a/main/gcc/config/rs6000/rs6000.md b/main/gcc/config/rs6000/rs6000.md index 83aaa58682b..a577d356296 100644 --- a/main/gcc/config/rs6000/rs6000.md +++ b/main/gcc/config/rs6000/rs6000.md @@ -56,6 +56,8 @@ (TFHAR_REGNO 114) (TFIAR_REGNO 115) (TEXASR_REGNO 116) + (FIRST_SPE_HIGH_REGNO 117) + (LAST_SPE_HIGH_REGNO 148) ]) ;; diff --git a/main/gcc/config/rs6000/sysv4.h b/main/gcc/config/rs6000/sysv4.h index 47323a6892e..446b3b581bd 100644 --- a/main/gcc/config/rs6000/sysv4.h +++ b/main/gcc/config/rs6000/sysv4.h @@ -292,7 +292,7 @@ do { \ /* An expression for the alignment of a structure field FIELD if the alignment computed in the usual way is COMPUTED. */ #define ADJUST_FIELD_ALIGN(FIELD, COMPUTED) \ - ((TARGET_ALTIVEC && TREE_CODE (TREE_TYPE (FIELD)) == VECTOR_TYPE) \ + (rs6000_special_adjust_field_align_p ((FIELD), (COMPUTED)) \ ? 128 : COMPUTED) #undef BIGGEST_FIELD_ALIGNMENT @@ -539,6 +539,7 @@ ENDIAN_SELECT(" -mbig", " -mlittle", DEFAULT_ASM_ENDIAN) #endif /* Pass -G xxx to the compiler. */ +#undef CC1_SPEC #define CC1_SPEC "%{G*} %(cc1_cpu)" \ "%{meabi: %{!mcall-*: -mcall-sysv }} \ %{!meabi: %{!mno-eabi: \ diff --git a/main/gcc/config/s390/s390.c b/main/gcc/config/s390/s390.c index bc6206e779f..03b85ff2ee1 100644 --- a/main/gcc/config/s390/s390.c +++ b/main/gcc/config/s390/s390.c @@ -10850,17 +10850,20 @@ static GTY(()) rtx s390_tpf_eh_return_symbol; void s390_emit_tpf_eh_return (rtx target) { - rtx insn, reg; + rtx insn, reg, orig_ra; if (!s390_tpf_eh_return_symbol) s390_tpf_eh_return_symbol = gen_rtx_SYMBOL_REF (Pmode, "__tpf_eh_return"); reg = gen_rtx_REG (Pmode, 2); + orig_ra = gen_rtx_REG (Pmode, 3); emit_move_insn (reg, target); + emit_move_insn (orig_ra, get_hard_reg_initial_val (Pmode, RETURN_REGNUM)); insn = s390_emit_call (s390_tpf_eh_return_symbol, NULL_RTX, reg, gen_rtx_REG (Pmode, RETURN_REGNUM)); use_reg (&CALL_INSN_FUNCTION_USAGE (insn), reg); + use_reg (&CALL_INSN_FUNCTION_USAGE (insn), orig_ra); emit_move_insn (EH_RETURN_HANDLER_RTX, reg); } diff --git a/main/gcc/config/sh/predicates.md b/main/gcc/config/sh/predicates.md index d7251f36e35..9eb0f1a7eaa 100644 --- a/main/gcc/config/sh/predicates.md +++ b/main/gcc/config/sh/predicates.md @@ -489,6 +489,10 @@ rtx mem_rtx = MEM_P (op) ? op : SUBREG_REG (op); rtx x = XEXP (mem_rtx, 0); + if (! ALLOW_INDEXED_ADDRESS + && GET_CODE (x) == PLUS && REG_P (XEXP (x, 0)) && REG_P (XEXP (x, 1))) + return false; + if ((mode == QImode || mode == HImode) && GET_CODE (x) == PLUS && REG_P (XEXP (x, 0)) @@ -567,6 +571,10 @@ rtx mem_rtx = MEM_P (op) ? op : SUBREG_REG (op); rtx x = XEXP (mem_rtx, 0); + if (! ALLOW_INDEXED_ADDRESS + && GET_CODE (x) == PLUS && REG_P (XEXP (x, 0)) && REG_P (XEXP (x, 1))) + return false; + if ((mode == QImode || mode == HImode) && GET_CODE (x) == PLUS && REG_P (XEXP (x, 0)) diff --git a/main/gcc/config/sh/sh.c b/main/gcc/config/sh/sh.c index 02468dadcdd..a19235d2411 100644 --- a/main/gcc/config/sh/sh.c +++ b/main/gcc/config/sh/sh.c @@ -10287,6 +10287,10 @@ sh_legitimate_index_p (enum machine_mode mode, rtx op, bool consider_sh2a, static bool sh_legitimate_address_p (enum machine_mode mode, rtx x, bool strict) { + if (! ALLOW_INDEXED_ADDRESS + && GET_CODE (x) == PLUS && REG_P (XEXP (x, 0)) && REG_P (XEXP (x, 1))) + return false; + if (REG_P (x) && REGNO (x) == GBR_REG) return true; @@ -10516,6 +10520,28 @@ sh_legitimize_reload_address (rtx *p, enum machine_mode mode, int opnum, enum reload_type type = (enum reload_type) itype; const int mode_sz = GET_MODE_SIZE (mode); + if (! ALLOW_INDEXED_ADDRESS + && GET_CODE (*p) == PLUS + && REG_P (XEXP (*p, 0)) && REG_P (XEXP (*p, 1))) + { + *p = copy_rtx (*p); + push_reload (*p, NULL_RTX, p, NULL, + BASE_REG_CLASS, Pmode, VOIDmode, 0, 0, opnum, type); + return true; + } + + if (! ALLOW_INDEXED_ADDRESS + && GET_CODE (*p) == PLUS + && GET_CODE (XEXP (*p, 0)) == PLUS) + { + rtx sum = gen_rtx_PLUS (Pmode, XEXP (XEXP (*p, 0), 0), + XEXP (XEXP (*p, 0), 1)); + *p = gen_rtx_PLUS (Pmode, sum, XEXP (*p, 1)); + push_reload (sum, NULL_RTX, &XEXP (*p, 0), NULL, + BASE_REG_CLASS, Pmode, VOIDmode, 0, 0, opnum, type); + return true; + } + if (TARGET_SHMEDIA) return false; diff --git a/main/gcc/config/vxworksae.h b/main/gcc/config/vxworksae.h index 02b89f7db00..8f82026d58b 100644 --- a/main/gcc/config/vxworksae.h +++ b/main/gcc/config/vxworksae.h @@ -68,3 +68,7 @@ along with GCC; see the file COPYING3. If not see } \ while (0) +/* Do VxWorks-specific parts of TARGET_OPTION_OVERRIDE. */ +#undef VXWORKS_OVERRIDE_OPTIONS +#define VXWORKS_OVERRIDE_OPTIONS vxworks_override_options () +extern void vxworks_override_options (void); diff --git a/main/gcc/configure b/main/gcc/configure index 3501cffe09f..7fa8e3976c1 100755 --- a/main/gcc/configure +++ b/main/gcc/configure @@ -9314,7 +9314,7 @@ fi for ac_func in times clock kill getrlimit setrlimit atoll atoq \ - sysconf strsignal getrusage nl_langinfo \ + popen sysconf strsignal getrusage nl_langinfo \ gettimeofday mbstowcs wcswidth mmap setlocale \ clearerr_unlocked feof_unlocked ferror_unlocked fflush_unlocked fgetc_unlocked fgets_unlocked fileno_unlocked fprintf_unlocked fputc_unlocked fputs_unlocked fread_unlocked fwrite_unlocked getchar_unlocked getc_unlocked putchar_unlocked putc_unlocked madvise do : diff --git a/main/gcc/configure.ac b/main/gcc/configure.ac index 97a553b4c6a..03a1dd3c04d 100644 --- a/main/gcc/configure.ac +++ b/main/gcc/configure.ac @@ -1128,7 +1128,7 @@ define(gcc_UNLOCKED_FUNCS, clearerr_unlocked feof_unlocked dnl fread_unlocked fwrite_unlocked getchar_unlocked getc_unlocked dnl putchar_unlocked putc_unlocked) AC_CHECK_FUNCS(times clock kill getrlimit setrlimit atoll atoq \ - sysconf strsignal getrusage nl_langinfo \ + popen sysconf strsignal getrusage nl_langinfo \ gettimeofday mbstowcs wcswidth mmap setlocale \ gcc_UNLOCKED_FUNCS madvise) diff --git a/main/gcc/coverage.c b/main/gcc/coverage.c index 34ff0e46a07..31d6f8c04ab 100644 --- a/main/gcc/coverage.c +++ b/main/gcc/coverage.c @@ -68,6 +68,7 @@ along with GCC; see the file COPYING3. If not see #include "filenames.h" #include "dwarf2asm.h" #include "target.h" +#include "params.h" #include "gcov-io.h" #include "gcov-io.c" @@ -1013,7 +1014,13 @@ get_coverage_counts_entry (struct function *func, unsigned counter) { counts_entry_t *entry, elt; - elt.ident = FUNC_DECL_GLOBAL_ID (func); + if (PARAM_VALUE (PARAM_PROFILE_FUNC_INTERNAL_ID) || flag_dyn_ipa) + elt.ident = FUNC_DECL_GLOBAL_ID (func); + else + { + gcc_assert (coverage_node_map_initialized_p ()); + elt.ident = cgraph_node::get (cfun->decl)->profile_id; + } elt.ctr = counter; entry = counts_hash->find (&elt); @@ -1091,13 +1098,13 @@ get_coverage_counts (unsigned counter, unsigned expected, return NULL; } - else if (entry->lineno_checksum != lineno_checksum) - { - warning (OPT_Wripa_opt_mismatch, - "Source location for function %qE have changed," - " the profile data may be out of date", - DECL_ASSEMBLER_NAME (current_function_decl)); - } + else if (entry->lineno_checksum != lineno_checksum) + { + warning (OPT_Wcoverage_mismatch, + "source locations for function %qE have changed," + " the profile data may be out of date", + DECL_ASSEMBLER_NAME (current_function_decl)); + } if (summary) *summary = &entry->summary; @@ -1340,12 +1347,14 @@ coverage_compute_profile_id (struct cgraph_node *n) { expanded_location xloc = expand_location (DECL_SOURCE_LOCATION (n->decl)); + bool use_name_only + = (PARAM_VALUE (PARAM_PROFILE_FUNC_INTERNAL_ID) == 0); - chksum = xloc.line; + chksum = (use_name_only ? 0 : xloc.line); chksum = coverage_checksum_string (chksum, xloc.file); chksum = coverage_checksum_string (chksum, IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (n->decl))); - if (first_global_object_name) + if (!use_name_only && first_global_object_name) chksum = coverage_checksum_string (chksum, first_global_object_name); chksum = coverage_checksum_string @@ -1404,7 +1413,15 @@ coverage_begin_function (unsigned lineno_checksum, unsigned cfg_checksum) /* Announce function */ offset = gcov_write_tag (GCOV_TAG_FUNCTION); - gcov_write_unsigned (FUNC_DECL_FUNC_ID (cfun)); + if (PARAM_VALUE (PARAM_PROFILE_FUNC_INTERNAL_ID) || flag_dyn_ipa) + gcov_write_unsigned (FUNC_DECL_FUNC_ID (cfun)); + else + { + gcc_assert (coverage_node_map_initialized_p ()); + gcov_write_unsigned ( + cgraph_node::get (current_function_decl)->profile_id); + } + gcov_write_unsigned (lineno_checksum); gcov_write_unsigned (cfg_checksum); gcov_write_string (IDENTIFIER_POINTER @@ -1441,8 +1458,15 @@ coverage_end_function (unsigned lineno_checksum, unsigned cfg_checksum) if (!DECL_EXTERNAL (current_function_decl)) { item = ggc_alloc (); - - item->ident = FUNC_DECL_FUNC_ID (cfun); + + if (PARAM_VALUE (PARAM_PROFILE_FUNC_INTERNAL_ID) || flag_dyn_ipa) + item->ident = FUNC_DECL_FUNC_ID (cfun); + else + { + gcc_assert (coverage_node_map_initialized_p ()); + item->ident = cgraph_node::get (cfun->decl)->profile_id; + } + item->lineno_checksum = lineno_checksum; item->cfg_checksum = cfg_checksum; @@ -1498,8 +1522,13 @@ coverage_dc_end_function (void) if (fn_ctr_mask) { const unsigned idx = GCOV_COUNTER_DIRECT_CALL; + unsigned ident; struct coverage_data *item = functions_head; - while (item && item->ident != (unsigned) FUNC_DECL_FUNC_ID (cfun)) + if (PARAM_VALUE (PARAM_PROFILE_FUNC_INTERNAL_ID) || flag_dyn_ipa) + ident = FUNC_DECL_GLOBAL_ID (cfun); + else + ident = cgraph_node::get (cfun->decl)->profile_id; + while (item && item->ident != ident) item = item->next; /* If a matching function entry hasn't been found, either this function diff --git a/main/gcc/coverage.h b/main/gcc/coverage.h index 192f98fdc34..b1f4c03735b 100644 --- a/main/gcc/coverage.h +++ b/main/gcc/coverage.h @@ -77,6 +77,7 @@ extern void emit_function_name (void); extern tree get_gcov_type (void); extern tree get_gcov_unsigned_t (void); extern tree get_const_string_type (void); +extern bool coverage_node_map_initialized_p (void); /* Mark this module as containing asm statements. */ extern void coverage_has_asm_stmt (void); diff --git a/main/gcc/cp/ChangeLog b/main/gcc/cp/ChangeLog index 779e087e444..9fdd4c7906b 100644 --- a/main/gcc/cp/ChangeLog +++ b/main/gcc/cp/ChangeLog @@ -1,3 +1,113 @@ +2014-08-02 Paolo Carlini + + PR c++/15339 + * decl.c (check_redeclaration_no_default_args): New. + (duplicate_decls): Use it, handle default arguments + in redeclarations of function templates. + +2014-08-02 Trevor Saunders + + * optimize.c, semantics.c: Use hash_map instead of pointer_map. + +2014-08-02 Trevor Saunders + + * class.c, cp-gimplify.c, cp-tree.h, decl.c, decl2.c, error.c, + method.c, name-lookup.c, pt.c, semantics.c, tree.c: Use hash_set + instead of pointer_set. + +2014-08-01 Jason Merrill + + PR c++/60417 + * init.c (build_vec_init): Set CONSTRUCTOR_IS_DIRECT_INIT on + init-list for trailing elements. + * typeck2.c (process_init_constructor_array): Likewise. + +2014-08-01 Paolo Carlini + + DR 217 again + * decl.c (duplicate_decls): Handle static member functions too. + +2014-08-01 Igor Zamyatin + + * cp-array-notation.c (expand_an_in_modify_expr): Fix the misprint + in error output. + +2014-08-01 Igor Zamyatin + + PR other/61963 + * parser.c (cp_parser_array_notation): Added check for array_type. + +2014-08-01 Igor Zamyatin + + PR middle-end/61455 + * cp-array-notation.c (expand_array_notation_exprs): Handling of + DECL_EXPR improved. Changed handling for INIT_EXPR. + +2014-08-01 Paolo Carlini + + * pt.c (lookup_template_class_1): Use DECL_TYPE_TEMPLATE_P. + +2014-08-01 Jakub Jelinek + + * cp-gimplify.c (cp_genericize_r): For -fsanitize=null and/or + -fsanitize=alignment call ubsan_maybe_instrument_reference + for casts to REFERENCE_TYPE and ubsan_maybe_instrument_member_call + for calls to member functions. + +2014-07-31 Marc Glisse + + PR c++/60517 + * typeck.c (maybe_warn_about_returning_address_of_local): Return + whether it is returning the address of a local variable. + (check_return_expr): Return 0 instead of the address of a local + variable. + +2014-07-30 Jason Merrill + + PR lto/53808 + PR c++/61659 + * pt.c (push_template_decl_real): Don't set DECL_COMDAT on friends. + +2014-07-30 Paolo Carlini + + PR c++/57397 + * pt.c (unify_arity): Add boolean parameter. + (unify_too_few_arguments): Likewise. + (type_unification_real): Diagnose correctly insufficient + arguments in the presence of trailing variadic parameters; + deducing multiple trailing packs as empty is fine. + +2014-07-30 Jason Merrill + + PR c++/61659 + PR c++/61687 + Revert: + * decl2.c (mark_all_virtuals): New variable. + (maybe_emit_vtables): Check it instead of flag_devirtualize. + (cp_write_global_declarations): Set it and give helpful diagnostic + if it introduces errors. + * class.c (finish_struct_1): Check it. + + PR lto/53808 + PR c++/61659 + * pt.c (push_template_decl_real): Set DECL_COMDAT on templates. + (check_explicit_specialization): Clear it on specializations. + * decl.c (duplicate_decls, start_decl): Likewise. + (grokmethod, grokfndecl): Set DECL_COMDAT on inlines. + * method.c (implicitly_declare_fn): Set DECL_COMDAT. Determine + linkage after setting the appropriate flags. + * tree.c (decl_linkage): Don't check DECL_COMDAT. + * decl2.c (mark_needed): Mark clones. + (import_export_decl): Not here. + +2014-07-25 Edward Smith-Rowland <3dw4rd@verizon.net> + + Implement N4051 - Allow typename in a template template parameter + * parser.c (cp_parser_type_parameter_key): New funtion; + (cp_parser_token_is_type_parameter_key): Ditto; + (cp_parser_type_parameter): Look for type-parameter-key for all versions + but pedwarn for less than cxx1z. + 2014-07-17 Paolo Carlini PR c++/50961 diff --git a/main/gcc/cp/class.c b/main/gcc/cp/class.c index 0f611e10a6f..811b581cd5a 100644 --- a/main/gcc/cp/class.c +++ b/main/gcc/cp/class.c @@ -5359,15 +5359,15 @@ finalize_literal_type_property (tree t) void explain_non_literal_class (tree t) { - static struct pointer_set_t *diagnosed; + static hash_set *diagnosed; if (!CLASS_TYPE_P (t)) return; t = TYPE_MAIN_VARIANT (t); if (diagnosed == NULL) - diagnosed = pointer_set_create (); - if (pointer_set_insert (diagnosed, t) != 0) + diagnosed = new hash_set; + if (diagnosed->add (t)) /* Already explained. */ return; @@ -6408,7 +6408,7 @@ finish_struct_1 (tree t) in every translation unit where the class definition appears. If we're devirtualizing, we can look into the vtable even if we aren't emitting it. */ - if (CLASSTYPE_KEY_METHOD (t) == NULL_TREE || flag_use_all_virtuals) + if (CLASSTYPE_KEY_METHOD (t) == NULL_TREE) keyed_classes = tree_cons (NULL_TREE, t, keyed_classes); } diff --git a/main/gcc/cp/cp-array-notation.c b/main/gcc/cp/cp-array-notation.c index b45449bc44d..6b910fc3a76 100644 --- a/main/gcc/cp/cp-array-notation.c +++ b/main/gcc/cp/cp-array-notation.c @@ -607,7 +607,7 @@ expand_an_in_modify_expr (location_t location, tree lhs, if (lhs_rank == 0 && rhs_rank != 0) { - error_at (location, "%qD cannot be scalar when %qD is not", lhs, rhs); + error_at (location, "%qE cannot be scalar when %qE is not", lhs, rhs); return error_mark_node; } if (lhs_rank != 0 && rhs_rank != 0 && lhs_rank != rhs_rank) @@ -1148,13 +1148,13 @@ expand_array_notation_exprs (tree t) case PARM_DECL: case NON_LVALUE_EXPR: case NOP_EXPR: - case INIT_EXPR: case ADDR_EXPR: case ARRAY_REF: case BIT_FIELD_REF: case VECTOR_CST: case COMPLEX_CST: return t; + case INIT_EXPR: case MODIFY_EXPR: if (contains_array_notation_expr (t)) t = expand_an_in_modify_expr (loc, TREE_OPERAND (t, 0), NOP_EXPR, @@ -1176,13 +1176,24 @@ expand_array_notation_exprs (tree t) return t; } case DECL_EXPR: - { - tree x = DECL_EXPR_DECL (t); - if (t && TREE_CODE (x) != FUNCTION_DECL) + if (contains_array_notation_expr (t)) + { + tree x = DECL_EXPR_DECL (t); if (DECL_INITIAL (x)) - t = expand_unary_array_notation_exprs (t); + { + location_t loc = DECL_SOURCE_LOCATION (x); + tree lhs = x; + tree rhs = DECL_INITIAL (x); + DECL_INITIAL (x) = NULL; + tree new_modify_expr = build_modify_expr (loc, lhs, + TREE_TYPE (lhs), + NOP_EXPR, + loc, rhs, + TREE_TYPE(rhs)); + t = expand_array_notation_exprs (new_modify_expr); + } + } return t; - } case STATEMENT_LIST: { tree_stmt_iterator i; diff --git a/main/gcc/cp/cp-gimplify.c b/main/gcc/cp/cp-gimplify.c index a35177bdbda..55d6c144dd6 100644 --- a/main/gcc/cp/cp-gimplify.c +++ b/main/gcc/cp/cp-gimplify.c @@ -871,7 +871,7 @@ omp_cxx_notice_variable (struct cp_genericize_omp_taskreg *omp_ctx, tree decl) struct cp_genericize_data { - struct pointer_set_t *p_set; + hash_set *p_set; vec bind_expr_stack; struct cp_genericize_omp_taskreg *omp_ctx; }; @@ -884,7 +884,7 @@ cp_genericize_r (tree *stmt_p, int *walk_subtrees, void *data) { tree stmt = *stmt_p; struct cp_genericize_data *wtd = (struct cp_genericize_data *) data; - struct pointer_set_t *p_set = wtd->p_set; + hash_set *p_set = wtd->p_set; /* If in an OpenMP context, note var uses. */ if (__builtin_expect (wtd->omp_ctx != NULL, 0) @@ -924,7 +924,7 @@ cp_genericize_r (tree *stmt_p, int *walk_subtrees, void *data) } /* Other than invisiref parms, don't walk the same tree twice. */ - if (pointer_set_contains (p_set, stmt)) + if (p_set->contains (stmt)) { *walk_subtrees = 0; return NULL_TREE; @@ -1198,8 +1198,29 @@ cp_genericize_r (tree *stmt_p, int *walk_subtrees, void *data) *stmt_p = size_one_node; return NULL; } + else if (flag_sanitize & (SANITIZE_NULL | SANITIZE_ALIGNMENT)) + { + if (TREE_CODE (stmt) == NOP_EXPR + && TREE_CODE (TREE_TYPE (stmt)) == REFERENCE_TYPE) + ubsan_maybe_instrument_reference (stmt); + else if (TREE_CODE (stmt) == CALL_EXPR) + { + tree fn = CALL_EXPR_FN (stmt); + if (fn != NULL_TREE + && !error_operand_p (fn) + && POINTER_TYPE_P (TREE_TYPE (fn)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (fn))) == METHOD_TYPE) + { + bool is_ctor + = TREE_CODE (fn) == ADDR_EXPR + && TREE_CODE (TREE_OPERAND (fn, 0)) == FUNCTION_DECL + && DECL_CONSTRUCTOR_P (TREE_OPERAND (fn, 0)); + ubsan_maybe_instrument_member_call (stmt, is_ctor); + } + } + } - pointer_set_insert (p_set, *stmt_p); + p_set->add (*stmt_p); return NULL; } @@ -1211,11 +1232,11 @@ cp_genericize_tree (tree* t_p) { struct cp_genericize_data wtd; - wtd.p_set = pointer_set_create (); + wtd.p_set = new hash_set; wtd.bind_expr_stack.create (0); wtd.omp_ctx = NULL; cp_walk_tree (t_p, cp_genericize_r, &wtd, NULL); - pointer_set_destroy (wtd.p_set); + delete wtd.p_set; wtd.bind_expr_stack.release (); } diff --git a/main/gcc/cp/cp-tree.h b/main/gcc/cp/cp-tree.h index b00b68a268e..30cdc5eb372 100644 --- a/main/gcc/cp/cp-tree.h +++ b/main/gcc/cp/cp-tree.h @@ -6035,7 +6035,7 @@ extern void verify_stmt_tree (tree); extern linkage_kind decl_linkage (tree); extern duration_kind decl_storage_duration (tree); extern tree cp_walk_subtrees (tree*, int*, walk_tree_fn, - void*, struct pointer_set_t*); + void*, hash_set *); #define cp_walk_tree(tp,func,data,pset) \ walk_tree_1 (tp, func, data, pset, cp_walk_subtrees) #define cp_walk_tree_without_duplicates(tp,func,data) \ diff --git a/main/gcc/cp/decl.c b/main/gcc/cp/decl.c index b4cb1e1ba3c..c8dc6c5bf02 100644 --- a/main/gcc/cp/decl.c +++ b/main/gcc/cp/decl.c @@ -1238,6 +1238,27 @@ validate_constexpr_redeclaration (tree old_decl, tree new_decl) return true; } +/* DECL is a redeclaration of a function or function template. If + it does have default arguments issue a diagnostic. Note: this + function is used to enforce the requirements in C++11 8.3.6 about + no default arguments in redeclarations. */ + +static void +check_redeclaration_no_default_args (tree decl) +{ + gcc_assert (DECL_DECLARES_FUNCTION_P (decl)); + + for (tree t = FUNCTION_FIRST_USER_PARMTYPE (decl); + t && t != void_list_node; t = TREE_CHAIN (t)) + if (TREE_PURPOSE (t)) + { + permerror (input_location, + "redeclaration of %q#D may not have default " + "arguments", decl); + return; + } +} + #define GNU_INLINE_P(fn) (DECL_DECLARED_INLINE_P (fn) \ && lookup_attribute ("gnu_inline", \ DECL_ATTRIBUTES (fn))) @@ -1708,31 +1729,23 @@ duplicate_decls (tree newdecl, tree olddecl, bool newdecl_is_friend) ; else if (TREE_CODE (olddecl) == FUNCTION_DECL) { - tree t1 = TYPE_ARG_TYPES (TREE_TYPE (olddecl)); - tree t2 = TYPE_ARG_TYPES (TREE_TYPE (newdecl)); - int i = 1; - - if (TREE_CODE (TREE_TYPE (newdecl)) == METHOD_TYPE) - t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2); - - if (TREE_CODE (TREE_TYPE (newdecl)) == METHOD_TYPE - && CLASSTYPE_TEMPLATE_INFO (CP_DECL_CONTEXT (newdecl))) - { - /* C++11 8.3.6/6. - Default arguments for a member function of a class template - shall be specified on the initial declaration of the member - function within the class template. */ - for (; t2 && t2 != void_list_node; t2 = TREE_CHAIN (t2)) - if (TREE_PURPOSE (t2)) - { - permerror (input_location, - "redeclaration of %q#D may not have default " - "arguments", newdecl); - break; - } - } + /* Note: free functions, as TEMPLATE_DECLs, are handled below. */ + if (DECL_FUNCTION_MEMBER_P (olddecl) + && (/* grokfndecl passes member function templates too + as FUNCTION_DECLs. */ + DECL_TEMPLATE_INFO (olddecl) + /* C++11 8.3.6/6. + Default arguments for a member function of a class + template shall be specified on the initial declaration + of the member function within the class template. */ + || CLASSTYPE_TEMPLATE_INFO (CP_DECL_CONTEXT (olddecl)))) + check_redeclaration_no_default_args (newdecl); else { + tree t1 = FUNCTION_FIRST_USER_PARMTYPE (olddecl); + tree t2 = FUNCTION_FIRST_USER_PARMTYPE (newdecl); + int i = 1; + for (; t1 && t1 != void_list_node; t1 = TREE_CHAIN (t1), t2 = TREE_CHAIN (t2), i++) if (TREE_PURPOSE (t1) && TREE_PURPOSE (t2)) @@ -1869,6 +1882,12 @@ duplicate_decls (tree newdecl, tree olddecl, bool newdecl_is_friend) if (DECL_FUNCTION_TEMPLATE_P (newdecl)) { + /* Per C++11 8.3.6/4, default arguments cannot be added in later + declarations of a function template. */ + check_redeclaration_no_default_args (newdecl); + + check_default_args (newdecl); + if (GNU_INLINE_P (old_result) != GNU_INLINE_P (new_result) && DECL_INITIAL (new_result)) { @@ -2199,6 +2218,7 @@ duplicate_decls (tree newdecl, tree olddecl, bool newdecl_is_friend) olddecl); SET_DECL_TEMPLATE_SPECIALIZATION (olddecl); + DECL_COMDAT (newdecl) = DECL_DECLARED_INLINE_P (olddecl); /* Don't propagate visibility from the template to the specialization here. We'll do that in determine_visibility if @@ -4713,6 +4733,10 @@ start_decl (const cp_declarator *declarator, if (DECL_LANG_SPECIFIC (decl) && DECL_USE_TEMPLATE (decl)) { SET_DECL_TEMPLATE_SPECIALIZATION (decl); + if (TREE_CODE (decl) == FUNCTION_DECL) + DECL_COMDAT (decl) = DECL_DECLARED_INLINE_P (decl); + else + DECL_COMDAT (decl) = false; /* [temp.expl.spec] An explicit specialization of a static data member of a template is a definition if the declaration @@ -7697,7 +7721,10 @@ grokfndecl (tree ctype, /* If the declaration was declared inline, mark it as such. */ if (inlinep) - DECL_DECLARED_INLINE_P (decl) = 1; + { + DECL_DECLARED_INLINE_P (decl) = 1; + DECL_COMDAT (decl) = 1; + } if (inlinep & 2) DECL_DECLARED_CONSTEXPR_P (decl) = true; @@ -8232,7 +8259,7 @@ check_static_variable_definition (tree decl, tree type) static tree stabilize_save_expr_r (tree *expr_p, int *walk_subtrees, void *data) { - struct pointer_set_t *pset = (struct pointer_set_t *)data; + hash_set *pset = (hash_set *)data; tree expr = *expr_p; if (TREE_CODE (expr) == SAVE_EXPR) { @@ -8252,10 +8279,9 @@ stabilize_save_expr_r (tree *expr_p, int *walk_subtrees, void *data) static void stabilize_vla_size (tree size) { - struct pointer_set_t *pset = pointer_set_create (); + hash_set pset; /* Break out any function calls into temporary variables. */ - cp_walk_tree (&size, stabilize_save_expr_r, pset, pset); - pointer_set_destroy (pset); + cp_walk_tree (&size, stabilize_save_expr_r, &pset, &pset); } /* Helper function for compute_array_index_type. Look for SIZEOF_EXPR @@ -14257,6 +14283,7 @@ grokmethod (cp_decl_specifier_seq *declspecs, check_template_shadow (fndecl); + DECL_COMDAT (fndecl) = 1; DECL_DECLARED_INLINE_P (fndecl) = 1; DECL_NO_INLINE_WARNING_P (fndecl) = 1; diff --git a/main/gcc/cp/decl2.c b/main/gcc/cp/decl2.c index 75130580014..9bbb2f55601 100644 --- a/main/gcc/cp/decl2.c +++ b/main/gcc/cp/decl2.c @@ -104,10 +104,7 @@ static GTY(()) vec *deferred_fns; static GTY(()) vec *no_linkage_decls; -/* Nonzero if we've instantiated everything used directly, and now want to - mark all virtual functions as used so that they are available for - devirtualization. */ -static int mark_all_virtuals; +extern int at_eof; /* Return a member function type (a METHOD_TYPE), given FNTYPE (a @@ -1927,6 +1924,12 @@ mark_needed (tree decl) definition. */ struct cgraph_node *node = cgraph_node::get_create (decl); node->forced_by_abi = true; + + /* #pragma interface and -frepo code can call mark_needed for + maybe-in-charge 'tors; mark the clones as well. */ + tree clone; + FOR_EACH_CLONE (clone, decl) + mark_needed (clone); } else if (TREE_CODE (decl) == VAR_DECL) { @@ -2011,15 +2014,6 @@ maybe_emit_vtables (tree ctype) if (DECL_COMDAT (primary_vtbl) && CLASSTYPE_DEBUG_REQUESTED (ctype)) note_debug_info_needed (ctype); - if (mark_all_virtuals && !DECL_ODR_USED (primary_vtbl)) - { - /* Make sure virtual functions get instantiated/synthesized so that - they can be inlined after devirtualization even if the vtable is - never emitted. */ - mark_used (primary_vtbl); - mark_vtable_entries (primary_vtbl); - return true; - } return false; } @@ -2725,17 +2719,7 @@ import_export_decl (tree decl) { /* The repository indicates that this entity should be defined here. Make sure the back end honors that request. */ - if (VAR_P (decl)) - mark_needed (decl); - else if (DECL_MAYBE_IN_CHARGE_CONSTRUCTOR_P (decl) - || DECL_MAYBE_IN_CHARGE_DESTRUCTOR_P (decl)) - { - tree clone; - FOR_EACH_CLONE (clone, decl) - mark_needed (clone); - } - else - mark_needed (decl); + mark_needed (decl); /* Output the definition as an ordinary strong definition. */ DECL_EXTERNAL (decl) = 0; DECL_INTERFACE_KNOWN (decl) = 1; @@ -3940,11 +3924,11 @@ generate_ctor_and_dtor_functions_for_priority (splay_tree_node n, void * data) supported, collect and return all the functions for which we should emit a hidden alias. */ -static struct pointer_set_t * +static hash_set * collect_candidates_for_java_method_aliases (void) { struct cgraph_node *node; - struct pointer_set_t *candidates = NULL; + hash_set *candidates = NULL; #ifndef HAVE_GAS_HIDDEN return candidates; @@ -3959,8 +3943,8 @@ collect_candidates_for_java_method_aliases (void) && TARGET_USE_LOCAL_THUNK_ALIAS_P (fndecl)) { if (candidates == NULL) - candidates = pointer_set_create (); - pointer_set_insert (candidates, fndecl); + candidates = new hash_set; + candidates->add (fndecl); } } @@ -3975,7 +3959,7 @@ collect_candidates_for_java_method_aliases (void) by collect_candidates_for_java_method_aliases. */ static void -build_java_method_aliases (struct pointer_set_t *candidates) +build_java_method_aliases (hash_set *candidates) { struct cgraph_node *node; @@ -3988,7 +3972,7 @@ build_java_method_aliases (struct pointer_set_t *candidates) tree fndecl = node->decl; if (TREE_ASM_WRITTEN (fndecl) - && pointer_set_contains (candidates, fndecl)) + && candidates->contains (fndecl)) { /* Mangle the name in a predictable way; we need to reference this from a java compiled object file. */ @@ -4315,8 +4299,6 @@ cp_process_pending_declarations (location_t locus) timevar_start (TV_PHASE_DEFERRED); - int errs = errorcount + sorrycount; - bool explained_devirt = false; do { @@ -4549,27 +4531,6 @@ cp_process_pending_declarations (location_t locus) pending_statics->length ())) reconsider = true; - if (flag_use_all_virtuals) - { - if (!reconsider && !mark_all_virtuals) - { - mark_all_virtuals = true; - reconsider = true; - errs = errorcount + sorrycount; - } - else if (mark_all_virtuals - && !explained_devirt - && (errorcount + sorrycount > errs)) - { - inform (global_dc->last_location, "this error is seen due to " - "instantiation of all virtual functions, which the C++ " - "standard says are always considered used; this is done " - "to support devirtualization optimizations, but can be " - "disabled with -fno-use-all-virtuals"); - explained_devirt = true; - } - } - retries++; } while (reconsider); @@ -4671,7 +4632,7 @@ cp_write_global_declarations (void) { bool reconsider = false; location_t locus; - struct pointer_set_t *candidates; + hash_set *candidates; locus = input_location; at_eof = 1; @@ -4768,7 +4729,7 @@ cp_write_global_declarations (void) if (candidates) { build_java_method_aliases (candidates); - pointer_set_destroy (candidates); + delete candidates; } finish_repo (); diff --git a/main/gcc/cp/error.c b/main/gcc/cp/error.c index fa3bdc4f6a5..c8987ee1d04 100644 --- a/main/gcc/cp/error.c +++ b/main/gcc/cp/error.c @@ -1325,7 +1325,7 @@ dump_template_decl (cxx_pretty_printer *pp, tree t, int flags) struct find_typenames_t { - struct pointer_set_t *p_set; + hash_set *p_set; vec *typenames; }; @@ -1351,7 +1351,7 @@ find_typenames_r (tree *tp, int *walk_subtrees, void *data) return NULL_TREE; } - if (mv && (mv == *tp || !pointer_set_insert (d->p_set, mv))) + if (mv && (mv == *tp || !d->p_set->add (mv))) vec_safe_push (d->typenames, mv); /* Search into class template arguments, which cp_walk_subtrees @@ -1367,11 +1367,11 @@ static vec * find_typenames (tree t) { struct find_typenames_t ft; - ft.p_set = pointer_set_create (); + ft.p_set = new hash_set; ft.typenames = NULL; cp_walk_tree (&TREE_TYPE (DECL_TEMPLATE_RESULT (t)), find_typenames_r, &ft, ft.p_set); - pointer_set_destroy (ft.p_set); + delete ft.p_set; return ft.typenames; } diff --git a/main/gcc/cp/init.c b/main/gcc/cp/init.c index 4124a8fbdef..e50a253140e 100644 --- a/main/gcc/cp/init.c +++ b/main/gcc/cp/init.c @@ -3550,19 +3550,11 @@ build_vec_init (tree base, tree maxindex, tree init, try_block = begin_try_block (); } - /* If the initializer is {}, then all elements are initialized from {}. - But for non-classes, that's the same as value-initialization. */ + bool empty_list = false; if (init && BRACE_ENCLOSED_INITIALIZER_P (init) && CONSTRUCTOR_NELTS (init) == 0) - { - if (CLASS_TYPE_P (type)) - /* Leave init alone. */; - else - { - init = NULL_TREE; - explicit_value_init_p = true; - } - } + /* Skip over the handling of non-empty init lists. */ + empty_list = true; /* Maybe pull out constant value when from_array? */ @@ -3682,14 +3674,8 @@ build_vec_init (tree base, tree maxindex, tree init, vec_free (new_vec); } - /* Any elements without explicit initializers get {}. */ - if (cxx_dialect >= cxx11 && AGGREGATE_TYPE_P (type)) - init = build_constructor (init_list_type_node, NULL); - else - { - init = NULL_TREE; - explicit_value_init_p = true; - } + /* Any elements without explicit initializers get T{}. */ + empty_list = true; } else if (from_array) { @@ -3704,6 +3690,26 @@ build_vec_init (tree base, tree maxindex, tree init, } } + /* If the initializer is {}, then all elements are initialized from T{}. + But for non-classes, that's the same as value-initialization. */ + if (empty_list) + { + if (cxx_dialect >= cxx11 && AGGREGATE_TYPE_P (type)) + { + if (BRACE_ENCLOSED_INITIALIZER_P (init) + && CONSTRUCTOR_NELTS (init) == 0) + /* Reuse it. */; + else + init = build_constructor (init_list_type_node, NULL); + CONSTRUCTOR_IS_DIRECT_INIT (init) = true; + } + else + { + init = NULL_TREE; + explicit_value_init_p = true; + } + } + /* Now, default-initialize any remaining elements. We don't need to do that if a) the type does not need constructing, or b) we've already initialized all the elements. diff --git a/main/gcc/cp/method.c b/main/gcc/cp/method.c index e5fa0c1b9da..56f50e1e5da 100644 --- a/main/gcc/cp/method.c +++ b/main/gcc/cp/method.c @@ -1480,7 +1480,7 @@ maybe_explain_implicit_delete (tree decl) if (DECL_DEFAULTED_FN (decl)) { /* Not marked GTY; it doesn't need to be GC'd or written to PCH. */ - static struct pointer_set_t *explained; + static hash_set *explained; special_function_kind sfk; location_t loc; @@ -1488,8 +1488,8 @@ maybe_explain_implicit_delete (tree decl) tree ctype; if (!explained) - explained = pointer_set_create (); - if (pointer_set_insert (explained, decl)) + explained = new hash_set; + if (explained->add (decl)) return true; sfk = special_function_p (decl); @@ -1798,8 +1798,6 @@ implicitly_declare_fn (special_function_kind kind, tree type, DECL_ARGUMENTS (fn) = this_parm; grokclassfn (type, fn, kind == sfk_destructor ? DTOR_FLAG : NO_SPECIAL); - set_linkage_according_to_type (type, fn); - rest_of_decl_compilation (fn, toplevel_bindings_p (), at_eof); DECL_IN_AGGR_P (fn) = 1; DECL_ARTIFICIAL (fn) = 1; DECL_DEFAULTED_FN (fn) = 1; @@ -1811,6 +1809,9 @@ implicitly_declare_fn (special_function_kind kind, tree type, DECL_EXTERNAL (fn) = true; DECL_NOT_REALLY_EXTERN (fn) = 1; DECL_DECLARED_INLINE_P (fn) = 1; + DECL_COMDAT (fn) = 1; + set_linkage_according_to_type (type, fn); + rest_of_decl_compilation (fn, toplevel_bindings_p (), at_eof); gcc_assert (!TREE_USED (fn)); /* Restore PROCESSING_TEMPLATE_DECL. */ diff --git a/main/gcc/cp/name-lookup.c b/main/gcc/cp/name-lookup.c index 65850d6b9a0..2a8aa7b64bf 100644 --- a/main/gcc/cp/name-lookup.c +++ b/main/gcc/cp/name-lookup.c @@ -35,7 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "debug.h" #include "c-family/c-pragma.h" #include "params.h" -#include "pointer-set.h" +#include "hash-set.h" /* The bindings for a particular name in a particular scope. */ @@ -5182,7 +5182,7 @@ struct arg_lookup vec *namespaces; vec *classes; tree functions; - struct pointer_set_t *fn_set; + hash_set *fn_set; }; static bool arg_assoc (struct arg_lookup*, tree); @@ -5205,7 +5205,7 @@ add_function (struct arg_lookup *k, tree fn) if (!is_overloaded_fn (fn)) /* All names except those of (possibly overloaded) functions and function templates are ignored. */; - else if (k->fn_set && pointer_set_insert (k->fn_set, fn)) + else if (k->fn_set && k->fn_set->add (fn)) /* It's already in the list. */; else if (!k->functions) k->functions = fn; @@ -5669,9 +5669,9 @@ lookup_arg_dependent_1 (tree name, tree fns, vec *args) /* We shouldn't be here if lookup found something other than namespace-scope functions. */ gcc_assert (DECL_NAMESPACE_SCOPE_P (OVL_CURRENT (fns))); - k.fn_set = pointer_set_create (); + k.fn_set = new hash_set; for (ovl = fns; ovl; ovl = OVL_NEXT (ovl)) - pointer_set_insert (k.fn_set, OVL_CURRENT (ovl)); + k.fn_set->add (OVL_CURRENT (ovl)); } else k.fn_set = NULL; @@ -5691,8 +5691,7 @@ lookup_arg_dependent_1 (tree name, tree fns, vec *args) release_tree_vector (k.classes); release_tree_vector (k.namespaces); - if (k.fn_set) - pointer_set_destroy (k.fn_set); + delete k.fn_set; return fns; } diff --git a/main/gcc/cp/optimize.c b/main/gcc/cp/optimize.c index 3cd804780eb..6eeca4d64f9 100644 --- a/main/gcc/cp/optimize.c +++ b/main/gcc/cp/optimize.c @@ -86,7 +86,7 @@ clone_body (tree clone, tree fn, void *arg_map) id.src_fn = fn; id.dst_fn = clone; id.src_cfun = DECL_STRUCT_FUNCTION (fn); - id.decl_map = (struct pointer_map_t *) arg_map; + id.decl_map = static_cast *> (arg_map); id.copy_decl = copy_decl_no_change; id.transform_call_graph_edges = CB_CGE_DUPLICATE; @@ -527,7 +527,7 @@ maybe_clone_body (tree fn) tree parm; tree clone_parm; int parmno; - struct pointer_map_t *decl_map; + hash_map *decl_map; bool alias = false; clone = fns[idx]; @@ -587,7 +587,7 @@ maybe_clone_body (tree fn) } /* Remap the parameters. */ - decl_map = pointer_map_create (); + decl_map = new hash_map; for (parmno = 0, parm = DECL_ARGUMENTS (fn), clone_parm = DECL_ARGUMENTS (clone); @@ -600,7 +600,7 @@ maybe_clone_body (tree fn) { tree in_charge; in_charge = in_charge_arg_for_name (DECL_NAME (clone)); - *pointer_map_insert (decl_map, parm) = in_charge; + decl_map->put (parm, in_charge); } else if (DECL_ARTIFICIAL (parm) && DECL_NAME (parm) == vtt_parm_identifier) @@ -611,19 +611,22 @@ maybe_clone_body (tree fn) if (DECL_HAS_VTT_PARM_P (clone)) { DECL_ABSTRACT_ORIGIN (clone_parm) = parm; - *pointer_map_insert (decl_map, parm) = clone_parm; + decl_map->put (parm, clone_parm); clone_parm = DECL_CHAIN (clone_parm); } /* Otherwise, map the VTT parameter to `NULL'. */ else - *pointer_map_insert (decl_map, parm) - = fold_convert (TREE_TYPE (parm), null_pointer_node); + { + tree t + = fold_convert (TREE_TYPE (parm), null_pointer_node); + decl_map->put (parm, t); + } } /* Map other parameters to their equivalents in the cloned function. */ else { - *pointer_map_insert (decl_map, parm) = clone_parm; + decl_map->put (parm, clone_parm); clone_parm = DECL_CHAIN (clone_parm); } } @@ -632,14 +635,14 @@ maybe_clone_body (tree fn) { parm = DECL_RESULT (fn); clone_parm = DECL_RESULT (clone); - *pointer_map_insert (decl_map, parm) = clone_parm; + decl_map->put (parm, clone_parm); } /* Clone the body. */ clone_body (clone, fn, decl_map); /* Clean up. */ - pointer_map_destroy (decl_map); + delete decl_map; } /* The clone can throw iff the original function can throw. */ diff --git a/main/gcc/cp/parser.c b/main/gcc/cp/parser.c index c87641bff32..e7a6c2cd5bc 100644 --- a/main/gcc/cp/parser.c +++ b/main/gcc/cp/parser.c @@ -2151,6 +2151,8 @@ static tree cp_parser_class_head (cp_parser *, bool *); static enum tag_types cp_parser_class_key (cp_parser *); +static void cp_parser_type_parameter_key + (cp_parser* parser); static void cp_parser_member_specification_opt (cp_parser *); static void cp_parser_member_declaration @@ -2409,6 +2411,8 @@ static bool cp_parser_nth_token_starts_template_argument_list_p (cp_parser *, size_t); static enum tag_types cp_parser_token_is_class_key (cp_token *); +static enum tag_types cp_parser_token_is_type_parameter_key + (cp_token *); static void cp_parser_check_class_key (enum tag_types, tree type); static void cp_parser_check_access_in_redeclaration @@ -6372,7 +6376,7 @@ cp_parser_array_notation (location_t loc, cp_parser *parser, tree *init_index, parser->colon_corrects_to_scope_p = saved_colon_corrects; if (*init_index == error_mark_node || length_index == error_mark_node - || stride == error_mark_node) + || stride == error_mark_node || array_type == error_mark_node) { if (cp_lexer_peek_token (parser->lexer)->type == CPP_CLOSE_SQUARE) cp_lexer_consume_token (parser->lexer); @@ -13399,8 +13403,8 @@ cp_parser_type_parameter (cp_parser* parser, bool *is_parameter_pack) cp_parser_template_parameter_list (parser); /* Look for the `>'. */ cp_parser_require (parser, CPP_GREATER, RT_GREATER); - /* Look for the `class' keyword. */ - cp_parser_require_keyword (parser, RID_CLASS, RT_CLASS); + /* Look for the `class' or 'typename' keywords. */ + cp_parser_type_parameter_key (parser); /* If the next token is an ellipsis, we have a template argument pack. */ if (cp_lexer_next_token_is (parser->lexer, CPP_ELLIPSIS)) @@ -20285,6 +20289,35 @@ cp_parser_class_key (cp_parser* parser) return tag_type; } +/* Parse a type-parameter-key. + + type-parameter-key: + class + typename + */ + +static void +cp_parser_type_parameter_key (cp_parser* parser) +{ + /* Look for the type-parameter-key. */ + enum tag_types tag_type = none_type; + cp_token *token = cp_lexer_peek_token (parser->lexer); + if ((tag_type = cp_parser_token_is_type_parameter_key (token)) != none_type) + { + cp_lexer_consume_token (parser->lexer); + if (pedantic && tag_type == typename_type && cxx_dialect < cxx1z) + /* typename is not allowed in a template template parameter + by the standard until C++1Z. */ + pedwarn (token->location, OPT_Wpedantic, + "ISO C++ forbids typename key in template template parameter;" + " use -std=c++1z or -std=gnu++1z"); + } + else + cp_parser_error (parser, "expected % or %"); + + return; +} + /* Parse an (optional) member-specification. member-specification: @@ -24803,6 +24836,27 @@ cp_parser_token_is_class_key (cp_token* token) } } +/* Returns the kind of tag indicated by TOKEN, if it is a type-parameter-key, + or none_type otherwise or if the token is null. */ + +static enum tag_types +cp_parser_token_is_type_parameter_key (cp_token* token) +{ + if (!token) + return none_type; + + switch (token->keyword) + { + case RID_CLASS: + return class_type; + case RID_TYPENAME: + return typename_type; + + default: + return none_type; + } +} + /* Issue an error message if the CLASS_KEY does not match the TYPE. */ static void diff --git a/main/gcc/cp/pt.c b/main/gcc/cp/pt.c index 2e744706dea..6b24ef1217a 100644 --- a/main/gcc/cp/pt.c +++ b/main/gcc/cp/pt.c @@ -156,7 +156,7 @@ static tree convert_nontype_argument (tree, tree, tsubst_flags_t); static tree convert_template_argument (tree, tree, tree, tsubst_flags_t, int, tree); static int for_each_template_parm (tree, tree_fn_t, void*, - struct pointer_set_t*, bool); + hash_set *, bool); static tree expand_template_argument_pack (tree); static tree build_template_parm_index (int, int, int, tree, tree); static bool inline_needs_template_parms (tree, bool); @@ -2796,6 +2796,9 @@ check_explicit_specialization (tree declarator, It's just the name of an instantiation. But, it's not a request for an instantiation, either. */ SET_DECL_IMPLICIT_INSTANTIATION (decl); + else + /* A specialization is not necessarily COMDAT. */ + DECL_COMDAT (decl) = DECL_DECLARED_INLINE_P (decl); /* Register this specialization so that we can find it again. */ @@ -3089,7 +3092,7 @@ struct find_parameter_pack_data tree* parameter_packs; /* Set of AST nodes that have been visited by the traversal. */ - struct pointer_set_t *visited; + hash_set *visited; }; /* Identifies all of the argument packs that occur in a template @@ -3252,9 +3255,9 @@ uses_parameter_packs (tree t) tree parameter_packs = NULL_TREE; struct find_parameter_pack_data ppd; ppd.parameter_packs = ¶meter_packs; - ppd.visited = pointer_set_create (); + ppd.visited = new hash_set; cp_walk_tree (&t, &find_parameter_packs_r, &ppd, ppd.visited); - pointer_set_destroy (ppd.visited); + delete ppd.visited; return parameter_packs != NULL_TREE; } @@ -3301,7 +3304,7 @@ make_pack_expansion (tree arg) /* Determine which parameter packs will be used by the base class expansion. */ - ppd.visited = pointer_set_create (); + ppd.visited = new hash_set; ppd.parameter_packs = ¶meter_packs; cp_walk_tree (&TREE_PURPOSE (arg), &find_parameter_packs_r, &ppd, ppd.visited); @@ -3309,7 +3312,7 @@ make_pack_expansion (tree arg) if (parameter_packs == NULL_TREE) { error ("base initializer expansion %<%T%> contains no parameter packs", arg); - pointer_set_destroy (ppd.visited); + delete ppd.visited; return error_mark_node; } @@ -3326,7 +3329,7 @@ make_pack_expansion (tree arg) } } - pointer_set_destroy (ppd.visited); + delete ppd.visited; /* Create the pack expansion type for the base type. */ purpose = cxx_make_type (TYPE_PACK_EXPANSION); @@ -3361,9 +3364,9 @@ make_pack_expansion (tree arg) /* Determine which parameter packs will be expanded. */ ppd.parameter_packs = ¶meter_packs; - ppd.visited = pointer_set_create (); + ppd.visited = new hash_set; cp_walk_tree (&arg, &find_parameter_packs_r, &ppd, ppd.visited); - pointer_set_destroy (ppd.visited); + delete ppd.visited; /* Make sure we found some parameter packs. */ if (parameter_packs == NULL_TREE) @@ -3408,9 +3411,9 @@ check_for_bare_parameter_packs (tree t) t = TREE_TYPE (t); ppd.parameter_packs = ¶meter_packs; - ppd.visited = pointer_set_create (); + ppd.visited = new hash_set; cp_walk_tree (&t, &find_parameter_packs_r, &ppd, ppd.visited); - pointer_set_destroy (ppd.visited); + delete ppd.visited; if (parameter_packs) { @@ -4390,11 +4393,11 @@ fixed_parameter_pack_p (tree parm) tree parameter_packs = NULL_TREE; struct find_parameter_pack_data ppd; ppd.parameter_packs = ¶meter_packs; - ppd.visited = pointer_set_create (); + ppd.visited = new hash_set; fixed_parameter_pack_p_1 (parm, &ppd); - pointer_set_destroy (ppd.visited); + delete ppd.visited; return parameter_packs; } @@ -5026,6 +5029,14 @@ template arguments to %qD do not match original template %qD", DECL_TEMPLATE_INFO (decl) = info; } + if (flag_implicit_templates + && !is_friend + && VAR_OR_FUNCTION_DECL_P (decl)) + /* Set DECL_COMDAT on template instantiations; if we force + them to be emitted by explicit instantiation or -frepo, + mark_needed will tell cgraph to do the right thing. */ + DECL_COMDAT (decl) = true; + return DECL_TEMPLATE_RESULT (tmpl); } @@ -5526,13 +5537,21 @@ unify_method_type_error (bool explain_p, tree arg) } static int -unify_arity (bool explain_p, int have, int wanted) +unify_arity (bool explain_p, int have, int wanted, bool least_p = false) { if (explain_p) - inform_n (input_location, wanted, - " candidate expects %d argument, %d provided", - " candidate expects %d arguments, %d provided", - wanted, have); + { + if (least_p) + inform_n (input_location, wanted, + " candidate expects at least %d argument, %d provided", + " candidate expects at least %d arguments, %d provided", + wanted, have); + else + inform_n (input_location, wanted, + " candidate expects %d argument, %d provided", + " candidate expects %d arguments, %d provided", + wanted, have); + } return 1; } @@ -5543,9 +5562,10 @@ unify_too_many_arguments (bool explain_p, int have, int wanted) } static int -unify_too_few_arguments (bool explain_p, int have, int wanted) +unify_too_few_arguments (bool explain_p, int have, int wanted, + bool least_p = false) { - return unify_arity (explain_p, have, wanted); + return unify_arity (explain_p, have, wanted, least_p); } static int @@ -7403,9 +7423,7 @@ lookup_template_class_1 (tree d1, tree arglist, tree in_decl, tree context, templ = TYPE_TI_TEMPLATE (d1); d1 = DECL_NAME (templ); } - else if (TREE_CODE (d1) == TEMPLATE_DECL - && DECL_TEMPLATE_RESULT (d1) - && TREE_CODE (DECL_TEMPLATE_RESULT (d1)) == TYPE_DECL) + else if (DECL_TYPE_TEMPLATE_P (d1)) { templ = d1; d1 = DECL_NAME (templ); @@ -7916,7 +7934,7 @@ struct pair_fn_data /* True when we should also visit template parameters that occur in non-deduced contexts. */ bool include_nondeduced_p; - struct pointer_set_t *visited; + hash_set *visited; }; /* Called from for_each_template_parm via walk_tree. */ @@ -8116,7 +8134,7 @@ for_each_template_parm_r (tree *tp, int *walk_subtrees, void *d) static int for_each_template_parm (tree t, tree_fn_t fn, void* data, - struct pointer_set_t *visited, + hash_set *visited, bool include_nondeduced_p) { struct pair_fn_data pfd; @@ -8135,7 +8153,7 @@ for_each_template_parm (tree t, tree_fn_t fn, void* data, if (visited) pfd.visited = visited; else - pfd.visited = pointer_set_create (); + pfd.visited = new hash_set; result = cp_walk_tree (&t, for_each_template_parm_r, &pfd, @@ -8144,7 +8162,7 @@ for_each_template_parm (tree t, tree_fn_t fn, void* data, /* Clean up. */ if (!visited) { - pointer_set_destroy (pfd.visited); + delete pfd.visited; pfd.visited = 0; } @@ -16622,18 +16640,26 @@ type_unification_real (tree tparms, are present, and the parm list isn't variadic. */ if (ia < nargs && parms == void_list_node) return unify_too_many_arguments (explain_p, nargs, ia); - /* Fail if parms are left and they don't have default values. */ + /* Fail if parms are left and they don't have default values and + they aren't all deduced as empty packs (c++/57397). This is + consistent with sufficient_parms_p. */ if (parms && parms != void_list_node && TREE_PURPOSE (parms) == NULL_TREE) { unsigned int count = nargs; tree p = parms; - while (p && p != void_list_node) + bool type_pack_p; + do { - count++; + type_pack_p = TREE_CODE (TREE_VALUE (p)) == TYPE_PACK_EXPANSION; + if (!type_pack_p) + count++; p = TREE_CHAIN (p); } - return unify_too_few_arguments (explain_p, ia, count); + while (p && p != void_list_node); + if (count != nargs) + return unify_too_few_arguments (explain_p, ia, count, + type_pack_p); } if (!subr) diff --git a/main/gcc/cp/semantics.c b/main/gcc/cp/semantics.c index c1666d54cb1..faa115a7f8e 100644 --- a/main/gcc/cp/semantics.c +++ b/main/gcc/cp/semantics.c @@ -4995,15 +4995,15 @@ clone_omp_udr (tree stmt, tree omp_decl1, tree omp_decl2, tree decl, tree placeholder) { copy_body_data id; - struct pointer_map_t *decl_map = pointer_map_create (); + hash_map decl_map; - *pointer_map_insert (decl_map, omp_decl1) = placeholder; - *pointer_map_insert (decl_map, omp_decl2) = decl; + decl_map.put (omp_decl1, placeholder); + decl_map.put (omp_decl2, decl); memset (&id, 0, sizeof (id)); id.src_fn = DECL_CONTEXT (omp_decl1); id.dst_fn = current_function_decl; id.src_cfun = DECL_STRUCT_FUNCTION (id.src_fn); - id.decl_map = decl_map; + id.decl_map = &decl_map; id.copy_decl = copy_decl_no_change; id.transform_call_graph_edges = CB_CGE_DUPLICATE; @@ -5012,7 +5012,6 @@ clone_omp_udr (tree stmt, tree omp_decl1, tree omp_decl2, id.transform_lang_insert_block = NULL; id.eh_lp_nr = 0; walk_tree (&stmt, copy_tree_body_r, &id, NULL); - pointer_map_destroy (decl_map); return stmt; } @@ -8058,7 +8057,7 @@ register_constexpr_fundef (tree fun, tree body) void explain_invalid_constexpr_fn (tree fun) { - static struct pointer_set_t *diagnosed; + static hash_set *diagnosed; tree body; location_t save_loc; /* Only diagnose defaulted functions or instantiations. */ @@ -8066,8 +8065,8 @@ explain_invalid_constexpr_fn (tree fun) && !is_instantiation_of_constexpr (fun)) return; if (diagnosed == NULL) - diagnosed = pointer_set_create (); - if (pointer_set_insert (diagnosed, fun) != 0) + diagnosed = new hash_set; + if (diagnosed->add (fun)) /* Already explained. */ return; diff --git a/main/gcc/cp/tree.c b/main/gcc/cp/tree.c index f6c5693df5f..3b53039cde3 100644 --- a/main/gcc/cp/tree.c +++ b/main/gcc/cp/tree.c @@ -3485,7 +3485,7 @@ cxx_type_hash_eq (const_tree typea, const_tree typeb) tree cp_walk_subtrees (tree *tp, int *walk_subtrees_p, walk_tree_fn func, - void *data, struct pointer_set_t *pset) + void *data, hash_set *pset) { enum tree_code code = TREE_CODE (*tp); tree result; @@ -3722,23 +3722,15 @@ decl_linkage (tree decl) if (TREE_CODE (decl) == CONST_DECL) return decl_linkage (TYPE_NAME (DECL_CONTEXT (decl))); - /* Some things that are not TREE_PUBLIC have external linkage, too. - For example, on targets that don't have weak symbols, we make all - template instantiations have internal linkage (in the object - file), but the symbols should still be treated as having external - linkage from the point of view of the language. */ - if (VAR_OR_FUNCTION_DECL_P (decl) - && DECL_COMDAT (decl)) - return lk_external; - /* Things in local scope do not have linkage, if they don't have TREE_PUBLIC set. */ if (decl_function_context (decl)) return lk_none; /* Members of the anonymous namespace also have TREE_PUBLIC unset, but - are considered to have external linkage for language purposes. DECLs - really meant to have internal linkage have DECL_THIS_STATIC set. */ + are considered to have external linkage for language purposes, as do + template instantiations on targets without weak symbols. DECLs really + meant to have internal linkage have DECL_THIS_STATIC set. */ if (TREE_CODE (decl) == TYPE_DECL) return lk_external; if (VAR_OR_FUNCTION_DECL_P (decl)) diff --git a/main/gcc/cp/typeck.c b/main/gcc/cp/typeck.c index 8832d26959d..373272a0d87 100644 --- a/main/gcc/cp/typeck.c +++ b/main/gcc/cp/typeck.c @@ -56,7 +56,7 @@ static tree pointer_diff (tree, tree, tree, tsubst_flags_t); static tree get_delta_difference (tree, tree, bool, bool, tsubst_flags_t); static void casts_away_constness_r (tree *, tree *, tsubst_flags_t); static bool casts_away_constness (tree, tree, tsubst_flags_t); -static void maybe_warn_about_returning_address_of_local (tree); +static bool maybe_warn_about_returning_address_of_local (tree); static tree lookup_destructor (tree, tree, tree, tsubst_flags_t); static void warn_args_num (location_t, tree, bool); static int convert_arguments (tree, vec **, tree, int, @@ -8300,9 +8300,9 @@ convert_for_initialization (tree exp, tree type, tree rhs, int flags, } /* If RETVAL is the address of, or a reference to, a local variable or - temporary give an appropriate warning. */ + temporary give an appropriate warning and return true. */ -static void +static bool maybe_warn_about_returning_address_of_local (tree retval) { tree valtype = TREE_TYPE (DECL_RESULT (current_function_decl)); @@ -8320,7 +8320,7 @@ maybe_warn_about_returning_address_of_local (tree retval) } if (TREE_CODE (whats_returned) != ADDR_EXPR) - return; + return false; whats_returned = TREE_OPERAND (whats_returned, 0); while (TREE_CODE (whats_returned) == COMPONENT_REF @@ -8333,14 +8333,14 @@ maybe_warn_about_returning_address_of_local (tree retval) || TREE_CODE (whats_returned) == TARGET_EXPR) { warning (OPT_Wreturn_local_addr, "returning reference to temporary"); - return; + return true; } if (VAR_P (whats_returned) && DECL_NAME (whats_returned) && TEMP_NAME_P (DECL_NAME (whats_returned))) { warning (OPT_Wreturn_local_addr, "reference to non-lvalue returned"); - return; + return true; } } @@ -8360,8 +8360,10 @@ maybe_warn_about_returning_address_of_local (tree retval) else warning (OPT_Wreturn_local_addr, "address of local variable %q+D " "returned", whats_returned); - return; + return true; } + + return false; } /* Check that returning RETVAL from the current function is valid. @@ -8654,8 +8656,9 @@ check_return_expr (tree retval, bool *no_warning) && TREE_CODE (TREE_OPERAND (retval, 1)) == AGGR_INIT_EXPR) retval = build2 (COMPOUND_EXPR, TREE_TYPE (retval), retval, TREE_OPERAND (retval, 0)); - else - maybe_warn_about_returning_address_of_local (retval); + else if (maybe_warn_about_returning_address_of_local (retval)) + retval = build2 (COMPOUND_EXPR, TREE_TYPE (retval), retval, + build_zero_cst (TREE_TYPE (retval))); } /* Actually copy the value returned into the appropriate location. */ diff --git a/main/gcc/cp/typeck2.c b/main/gcc/cp/typeck2.c index 59a47605d6c..20523faf09b 100644 --- a/main/gcc/cp/typeck2.c +++ b/main/gcc/cp/typeck2.c @@ -1239,8 +1239,9 @@ process_init_constructor_array (tree type, tree init, { /* If this type needs constructors run for default-initialization, we can't rely on the back end to do it for us, so make the - initialization explicit by list-initializing from {}. */ + initialization explicit by list-initializing from T{}. */ next = build_constructor (init_list_type_node, NULL); + CONSTRUCTOR_IS_DIRECT_INIT (next) = true; next = massage_init_elt (TREE_TYPE (type), next, complain); if (initializer_zerop (next)) /* The default zero-initialization is fine for us; don't diff --git a/main/gcc/cprop.c b/main/gcc/cprop.c index 6291c911e8e..4234afabe5e 100644 --- a/main/gcc/cprop.c +++ b/main/gcc/cprop.c @@ -167,7 +167,7 @@ reg_available_p (const_rtx x, const_rtx insn ATTRIBUTE_UNUSED) ??? May need to make things more elaborate. Later, as necessary. */ static unsigned int -hash_set (int regno, int hash_table_size) +hash_mod (int regno, int hash_table_size) { return (unsigned) regno % hash_table_size; } @@ -187,7 +187,7 @@ insert_set_in_table (rtx dest, rtx src, rtx insn, struct hash_table_d *table, struct expr *cur_expr, *last_expr = NULL; struct occr *cur_occr; - hash = hash_set (REGNO (dest), table->size); + hash = hash_mod (REGNO (dest), table->size); for (cur_expr = table->table[hash]; cur_expr; cur_expr = cur_expr->next_same_hash) @@ -483,7 +483,7 @@ compute_hash_table (struct hash_table_d *table) static struct expr * lookup_set (unsigned int regno, struct hash_table_d *table) { - unsigned int hash = hash_set (regno, table->size); + unsigned int hash = hash_mod (regno, table->size); struct expr *expr; expr = table->table[hash]; diff --git a/main/gcc/cse.c b/main/gcc/cse.c index 34f93643cdf..dd9a076fcfa 100644 --- a/main/gcc/cse.c +++ b/main/gcc/cse.c @@ -41,7 +41,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-pass.h" #include "df.h" #include "dbgcnt.h" -#include "pointer-set.h" +#include "hash-set.h" /* The basic idea of common subexpression elimination is to go through the code, keeping a record of expressions that would @@ -2906,7 +2906,7 @@ find_comparison_args (enum rtx_code code, rtx *parg1, rtx *parg2, enum machine_mode *pmode1, enum machine_mode *pmode2) { rtx arg1, arg2; - struct pointer_set_t *visited = NULL; + hash_set *visited = NULL; /* Set nonzero when we find something of interest. */ rtx x = NULL; @@ -2923,8 +2923,8 @@ find_comparison_args (enum rtx_code code, rtx *parg1, rtx *parg2, if (x) { if (!visited) - visited = pointer_set_create (); - pointer_set_insert (visited, x); + visited = new hash_set; + visited->add (x); x = 0; } @@ -3005,7 +3005,7 @@ find_comparison_args (enum rtx_code code, rtx *parg1, rtx *parg2, continue; /* If it's a comparison we've used before, skip it. */ - if (visited && pointer_set_contains (visited, p->exp)) + if (visited && visited->contains (p->exp)) continue; if (GET_CODE (p->exp) == COMPARE @@ -3087,7 +3087,7 @@ find_comparison_args (enum rtx_code code, rtx *parg1, rtx *parg2, *parg1 = fold_rtx (arg1, 0), *parg2 = fold_rtx (arg2, 0); if (visited) - pointer_set_destroy (visited); + delete visited; return code; } diff --git a/main/gcc/data-streamer-out.c b/main/gcc/data-streamer-out.c index 8eefd2f855e..4b3a0119dbe 100644 --- a/main/gcc/data-streamer-out.c +++ b/main/gcc/data-streamer-out.c @@ -32,6 +32,49 @@ along with GCC; see the file COPYING3. If not see #include "gimple.h" #include "data-streamer.h" + +/* Adds a new block to output stream OBS. */ + +void +lto_append_block (struct lto_output_stream *obs) +{ + struct lto_char_ptr_base *new_block; + + gcc_assert (obs->left_in_block == 0); + + if (obs->first_block == NULL) + { + /* This is the first time the stream has been written + into. */ + obs->block_size = 1024; + new_block = (struct lto_char_ptr_base*) xmalloc (obs->block_size); + obs->first_block = new_block; + } + else + { + struct lto_char_ptr_base *tptr; + /* Get a new block that is twice as big as the last block + and link it into the list. */ + obs->block_size *= 2; + new_block = (struct lto_char_ptr_base*) xmalloc (obs->block_size); + /* The first bytes of the block are reserved as a pointer to + the next block. Set the chain of the full block to the + pointer to the new block. */ + tptr = obs->current_block; + tptr->ptr = (char *) new_block; + } + + /* Set the place for the next char at the first position after the + chain to the next block. */ + obs->current_pointer + = ((char *) new_block) + sizeof (struct lto_char_ptr_base); + obs->current_block = new_block; + /* Null out the newly allocated block's pointer to the next block. */ + new_block->ptr = NULL; + obs->left_in_block = obs->block_size - sizeof (struct lto_char_ptr_base); +} + + /* Return index used to reference STRING of LEN characters in the string table in OB. The string might or might not include a trailing '\0'. Then put the index onto the INDEX_STREAM. @@ -71,7 +114,7 @@ streamer_string_index (struct output_block *ob, const char *s, unsigned int len, new_slot->slot_num = start; *slot = new_slot; streamer_write_uhwi_stream (string_stream, len); - lto_output_data_stream (string_stream, string, len); + streamer_write_data_stream (string_stream, string, len); return start + 1; } else @@ -304,3 +347,34 @@ streamer_write_gcov_count_stream (struct lto_output_stream *obs, gcov_type work) gcc_assert ((HOST_WIDE_INT) work == work); streamer_write_hwi_stream (obs, work); } + +/* Write raw DATA of length LEN to the output block OB. */ + +void +streamer_write_data_stream (struct lto_output_stream *obs, const void *data, + size_t len) +{ + while (len) + { + size_t copy; + + /* No space left. */ + if (obs->left_in_block == 0) + lto_append_block (obs); + + /* Determine how many bytes to copy in this loop. */ + if (len <= obs->left_in_block) + copy = len; + else + copy = obs->left_in_block; + + /* Copy the data and do bookkeeping. */ + memcpy (obs->current_pointer, data, copy); + obs->current_pointer += copy; + obs->total_size += copy; + obs->left_in_block -= copy; + data = (const char *) data + copy; + len -= copy; + } +} + diff --git a/main/gcc/data-streamer.h b/main/gcc/data-streamer.h index dc7b7207add..56fedd2764d 100644 --- a/main/gcc/data-streamer.h +++ b/main/gcc/data-streamer.h @@ -70,6 +70,8 @@ void streamer_write_uhwi_stream (struct lto_output_stream *, unsigned HOST_WIDE_INT); void streamer_write_hwi_stream (struct lto_output_stream *, HOST_WIDE_INT); void streamer_write_gcov_count_stream (struct lto_output_stream *, gcov_type); +void streamer_write_data_stream (struct lto_output_stream *, const void *, + size_t); /* In data-streamer-in.c */ const char *string_for_index (struct data_in *, unsigned int, unsigned int *); diff --git a/main/gcc/doc/cpp.texi b/main/gcc/doc/cpp.texi index aaed739fb35..0a6e50caac9 100644 --- a/main/gcc/doc/cpp.texi +++ b/main/gcc/doc/cpp.texi @@ -2354,8 +2354,8 @@ This macro is defined, with value 3, when @option{-fstack-protector-strong} is in use. @item __SANITIZE_ADDRESS__ -This macro is defined, with value 1, when @option{-fsanitize=address} is -in use. +This macro is defined, with value 1, when @option{-fsanitize=address} +or @option{-fsanitize=kernel-address} are in use. @item __TIMESTAMP__ This macro expands to a string constant that describes the date and time diff --git a/main/gcc/doc/extend.texi b/main/gcc/doc/extend.texi index 53fab8d21e6..591aaeba3e3 100644 --- a/main/gcc/doc/extend.texi +++ b/main/gcc/doc/extend.texi @@ -5890,6 +5890,17 @@ and caught in another, the class must have default visibility. Otherwise the two shared objects are unable to use the same typeinfo node and exception handling will break. +@item designated_init +This attribute may only be applied to structure types. It indicates +that any initialization of an object of this type must use designated +initializers rather than positional initializers. The intent of this +attribute is to allow the programmer to indicate that a structure's +layout may change, and that therefore relying on positional +initialization will result in future breakage. + +GCC emits warnings based on this attribute by default; use +@option{-Wno-designated-init} to suppress them. + @end table To specify multiple attributes, separate them by commas within the diff --git a/main/gcc/doc/invoke.texi b/main/gcc/doc/invoke.texi index 9cfa84336c0..0d7c3305e96 100644 --- a/main/gcc/doc/invoke.texi +++ b/main/gcc/doc/invoke.texi @@ -189,7 +189,7 @@ in the following sections. -fno-pretty-templates @gol -frepo -fno-rtti -fstats -ftemplate-backtrace-limit=@var{n} @gol -ftemplate-depth=@var{n} @gol --fno-threadsafe-statics -fno-use-all-virtuals -fuse-cxa-atexit @gol +-fno-threadsafe-statics -fuse-cxa-atexit @gol -fno-weak -nostdinc++ @gol -fvisibility-inlines-hidden @gol -fvtable-verify=@var{std|preinit|none} @gol @@ -244,8 +244,8 @@ Objective-C and Objective-C++ Dialects}. -Wc++-compat -Wc++11-compat -Wcast-align -Wcast-qual @gol -Wchar-subscripts -Wclobbered -Wcomment -Wconditionally-supported @gol -Wconversion -Wcoverage-mismatch -Wdate-time -Wdelete-incomplete -Wno-cpp @gol --Wno-deprecated -Wno-deprecated-declarations -Wdisabled-optimization @gol --Wno-discarded-qualifiers @gol +-Wno-deprecated -Wno-deprecated-declarations -Wno-designated-init @gol +-Wdisabled-optimization -Wno-discarded-qualifiers @gol -Wno-div-by-zero -Wdouble-promotion -Wempty-body -Wenum-compare @gol -Wno-endif-labels -Werror -Werror=* @gol -Wfatal-errors -Wfloat-equal -Wforce-warnings -Wformat -Wformat=2 @gol @@ -272,6 +272,7 @@ Objective-C and Objective-C++ Dialects}. -Wstack-protector -Wstack-usage=@var{len} -Wstrict-aliasing @gol -Wstrict-aliasing=n @gol -Wstrict-overflow -Wstrict-overflow=@var{n} @gol -Wsuggest-attribute=@r{[}pure@r{|}const@r{|}noreturn@r{|}format@r{]} @gol +-Wsuggest-final-types @gol -Wsuggest-final-methods @gol -Wmissing-format-attribute @gol -Wswitch -Wswitch-default -Wswitch-enum -Wswitch-bool -Wsync-nand @gol -Wsystem-headers -Wtrampolines -Wtrigraphs -Wtype-limits -Wundef @gol @@ -2337,16 +2338,6 @@ ABI for thread-safe initialization of local statics. You can use this option to reduce code size slightly in code that doesn't need to be thread-safe. -@item -fno-use-all-virtuals -@opindex fno-use-all-virtuals -By default, G++ now treats all virtual functions declared in a -translation unit as odr-used, so they will be instantiated or -synthesized if possible even if they are not needed for the final -output. This is done so that such functions can be inlined after -devirtualization changes an indirect call into a direct call. If this -instantiation and synthesis prevents your code from compiling -successfully, you can disable it with this option. - @item -fuse-cxa-atexit @opindex fuse-cxa-atexit Register destructors for objects with static storage duration with the @@ -4296,6 +4287,25 @@ case, and some functions for which @code{format} attributes are appropriate may not be detected. @end table +@item -Wsuggest-final-types +@opindex Wno-suggest-final-types +@opindex Wsuggest-final-types +Warn about types with virtual methods where code quality would be improved +if the type was declared with C++11 final specifier, or, if possible, +declared in anonymous namespace. This allows GCC to devritualize more aggressively +the polymorphic calls. This warning is more effective with link time optimization, +where the information about the class hiearchy graph is more complete. + +@item -Wsuggest-final-methods +@opindex Wno-suggest-final-methods +@opindex Wsuggest-final-methods +Warn about virtual methods where code quality would be improved if the method +was declared with C++11 final specifier, or, if possible, its type was declared +in the anonymous namespace or with final specifier. This warning is more +effective with link time optimization, where the information about the class +hiearchy graph is more complete. It is recommended to first consider suggestins +of @option{-Wsuggest-final-types} and then rebuild with new annotations. + @item -Warray-bounds @opindex Wno-array-bounds @opindex Warray-bounds @@ -5057,11 +5067,11 @@ attribute. @opindex Woverflow Do not warn about compile-time overflow in constant expressions. -@opindex Wodr +@item -Wno-odr @opindex Wno-odr @opindex Wodr -Warn about One Definition Rule violations during link time optimization. -Require @option{-flto-odr-type-merging} to be enabled. Enabled by default +Warn about One Definition Rule violations during link-time optimization. +Requires @option{-flto-odr-type-merging} to be enabled. Enabled by default. @item -Wopenmp-simd @opindex Wopenm-simd @@ -5316,6 +5326,12 @@ a suffix. When used together with @option{-Wsystem-headers} it warns about such constants in system header files. This can be useful when preparing code to use with the @code{FLOAT_CONST_DECIMAL64} pragma from the decimal floating-point extension to C99. + +@item -Wno-designated-init @r{(C and Objective-C only)} +Suppress warnings when a positional initializer is used to initialize +a structure that has been marked with the @code{designated_init} +attribute. + @end table @node Debugging Options @@ -5541,6 +5557,11 @@ more details. The run-time behavior can be influenced using the @url{https://code.google.com/p/address-sanitizer/wiki/Flags#Run-time_flags} for a list of supported options. +@item -fsanitize=kernel-address +@opindex fsanitize=kernel-address +Enable AddressSanitizer for Linux kernel. +See @uref{http://code.google.com/p/address-sanitizer/wiki/AddressSanitizerForKernel} for more details. + @item -fsanitize=thread @opindex fsanitize=thread Enable ThreadSanitizer, a fast data race detector. @@ -5598,7 +5619,8 @@ instead. This option enables pointer checking. Particularly, the application built with this option turned on will issue an error message when it tries to dereference a NULL pointer, or if a reference (possibly an -rvalue reference) is bound to a NULL pointer. +rvalue reference) is bound to a NULL pointer, or if a method is invoked +on an object pointed by a NULL pointer. @item -fsanitize=return @opindex fsanitize=return @@ -5625,6 +5647,13 @@ This option enables instrumentation of array bounds. Various out of bounds accesses are detected. Flexible array members and initializers of variables with static storage are not instrumented. +@item -fsanitize=alignment +@opindex fsanitize=alignment + +This option enables checking of alignment of pointers when they are +dereferenced, or when a reference is bound to insufficiently aligned target, +or when a method or constructor is invoked on insufficiently aligned object. + @item -fsanitize=float-divide-by-zero @opindex fsanitize=float-divide-by-zero Detect floating-point division by zero. Unlike other similar options, @@ -7086,25 +7115,31 @@ compilation time. @option{-O} turns on the following optimization flags: @gccoptlist{ -fauto-inc-dec @gol +-fbranch-count-reg @gol +-fcombine-stack-adjustments @gol -fcompare-elim @gol -fcprop-registers @gol -fdce @gol -fdefer-pop @gol -fdelayed-branch @gol -fdse @gol +-fforward-propagate @gol -fguess-branch-probability @gol -fif-conversion2 @gol -fif-conversion @gol +-finline-functions-called-once @gol -fipa-pure-const @gol -fipa-profile @gol -fipa-reference @gol --fmerge-constants +-fmerge-constants @gol +-fmove-loop-invariants @gol +-fshrink-wrap @gol -fsplit-wide-types @gol -ftree-bit-ccp @gol --ftree-builtin-call-dce @gol -ftree-ccp @gol -fssa-phiopt @gol -ftree-ch @gol +-ftree-copy-prop @gol -ftree-copyrename @gol -ftree-dce @gol -ftree-dominator-opts @gol @@ -7112,6 +7147,7 @@ compilation time. -ftree-forwprop @gol -ftree-fre @gol -ftree-phiprop @gol +-ftree-sink @gol -ftree-slsr @gol -ftree-sra @gol -ftree-pta @gol @@ -7143,19 +7179,23 @@ also turns on the following optimization flags: -fhoist-adjacent-loads @gol -finline-small-functions @gol -findirect-inlining @gol +-fipa-cp @gol -fipa-sra @gol -fisolate-erroneous-paths-dereference @gol -foptimize-sibling-calls @gol +-foptimize-strlen @gol -fpartial-inlining @gol -fpeephole2 @gol --freorder-blocks -freorder-functions @gol +-freorder-blocks -freorder-blocks-and-partition -freorder-functions @gol -frerun-cse-after-loop @gol -fsched-interblock -fsched-spec @gol -fschedule-insns -fschedule-insns2 @gol -fstrict-aliasing -fstrict-overflow @gol +-ftree-builtin-call-dce @gol -ftree-switch-conversion -ftree-tail-merge @gol -ftree-pre @gol --ftree-vrp} +-ftree-vrp @gol +-fuse-caller-save} Please note the warning under @option{-fgcse} about invoking @option{-O2} on programs that use computed gotos. @@ -7279,6 +7319,14 @@ Optimize sibling and tail recursive calls. Enabled at levels @option{-O2}, @option{-O3}, @option{-Os}. +@item -foptimize-strlen +@opindex foptimize-strlen +Optimize various standard C string functions (e.g. @code{strlen}, +@code{strchr} or @code{strcpy}) and +their _FORTIFY_SOURCE counterparts into faster alternatives. + +Enabled at levels @option{-O2}, @option{-O3}. + @item -fno-inline @opindex fno-inline Do not expand any functions inline apart from those marked with @@ -7444,6 +7492,8 @@ register, compare it against zero, then branch based upon the result. This option is only meaningful on architectures that support such instructions, which include x86, PowerPC, IA-64 and S/390. +Enabled by default at -O1 and higher. + The default is @option{-fbranch-count-reg}. @item -fno-function-cse @@ -9821,7 +9871,7 @@ before applying @option{--param inline-unit-growth}. The default is 10000. @item inline-unit-growth Specifies maximal overall growth of the compilation unit caused by inlining. The default value is 30 which limits unit growth to 1.3 times the original -size. Cold functions (either marked cold via an attribibute or by profile +size. Cold functions (either marked cold via an attribute or by profile feedback) are not accounted into the unit size. @item ipcp-unit-growth @@ -9888,6 +9938,14 @@ Deeper chains are still handled by late inlining. Probability (in percent) that C++ inline function with comdat visibility are shared across multiple compilation units. The default value is 20. +@item profile-func-internal-id +@itemx profile-func-internal-id +A parameter to control whether to use function internal id in profile +database lookup. If the value is 0, the compiler will use id that +is based on function assembler name and filename, which makes old profile +data more tolerant to source changes such as function reordering etc. +The default value is 0. + @item min-vect-loop-bound The minimum number of iterations under which loops are not vectorized when @option{-ftree-vectorize} is used. The number of iterations after @@ -13372,6 +13430,14 @@ the device name as from the AVR user manual. The difference between If @var{device} is not a device but only a core architecture like @code{avr51}, this macro will not be defined. +@item __AVR_DEVICE_NAME__ +Setting @code{-mmcu=@var{device}} defines this built-in macro to +the device's name. For example, with @code{-mmcu=atmega8} the macro +will be defined to @code{atmega8}. + +If @var{device} is not a device but only a core architecture like +@code{avr51}, this macro will not be defined. + @item __AVR_XMEGA__ The device / architecture belongs to the XMEGA family of devices. diff --git a/main/gcc/doc/md.texi b/main/gcc/doc/md.texi index fde67d7a01e..dd7861188af 100644 --- a/main/gcc/doc/md.texi +++ b/main/gcc/doc/md.texi @@ -5316,10 +5316,18 @@ generating the instruction. The @code{ffs} built-in function of C always uses the mode which corresponds to the C data type @code{int}. +@cindex @code{clrsb@var{m}2} instruction pattern +@item @samp{clrsb@var{m}2} +Count leading redundant sign bits. +Store into operand 0 the number of redundant sign bits in operand 1, starting +at the most significant bit position. +A redundant sign bit is defined as any sign bit after the first. As such, +this count will be one less than the count of leading sign bits. + @cindex @code{clz@var{m}2} instruction pattern @item @samp{clz@var{m}2} -Store into operand 0 the number of leading 0-bits in @var{x}, starting -at the most significant bit position. If @var{x} is 0, the +Store into operand 0 the number of leading 0-bits in operand 1, starting +at the most significant bit position. If operand 1 is 0, the @code{CLZ_DEFINED_VALUE_AT_ZERO} (@pxref{Misc}) macro defines if the result is undefined or has a useful value. @var{m} is the mode of operand 0; operand 1's mode is @@ -5328,8 +5336,8 @@ operand to that mode before generating the instruction. @cindex @code{ctz@var{m}2} instruction pattern @item @samp{ctz@var{m}2} -Store into operand 0 the number of trailing 0-bits in @var{x}, starting -at the least significant bit position. If @var{x} is 0, the +Store into operand 0 the number of trailing 0-bits in operand 1, starting +at the least significant bit position. If operand 1 is 0, the @code{CTZ_DEFINED_VALUE_AT_ZERO} (@pxref{Misc}) macro defines if the result is undefined or has a useful value. @var{m} is the mode of operand 0; operand 1's mode is @@ -5338,15 +5346,15 @@ operand to that mode before generating the instruction. @cindex @code{popcount@var{m}2} instruction pattern @item @samp{popcount@var{m}2} -Store into operand 0 the number of 1-bits in @var{x}. @var{m} is the +Store into operand 0 the number of 1-bits in operand 1. @var{m} is the mode of operand 0; operand 1's mode is specified by the instruction pattern, and the compiler will convert the operand to that mode before generating the instruction. @cindex @code{parity@var{m}2} instruction pattern @item @samp{parity@var{m}2} -Store into operand 0 the parity of @var{x}, i.e.@: the number of 1-bits -in @var{x} modulo 2. @var{m} is the mode of operand 0; operand 1's mode +Store into operand 0 the parity of operand 1, i.e.@: the number of 1-bits +in operand 1 modulo 2. @var{m} is the mode of operand 0; operand 1's mode is specified by the instruction pattern, and the compiler will convert the operand to that mode before generating the instruction. diff --git a/main/gcc/doc/sourcebuild.texi b/main/gcc/doc/sourcebuild.texi index 39152df272a..0793f80d3e1 100644 --- a/main/gcc/doc/sourcebuild.texi +++ b/main/gcc/doc/sourcebuild.texi @@ -1804,6 +1804,15 @@ Target is a VxWorks RTP. @item wchar Target supports wide characters. + +@item glibc +Target supports glibc + +@item glibc_2_12_or_later +Target supports glibc 2.12 or later + +@item glibc_2_11_or_earlier +Target supports glibc 2.11 or earlier @end table @subsubsection Other attributes diff --git a/main/gcc/dwarf2out.c b/main/gcc/dwarf2out.c index ad725e5bc77..db32ddee751 100644 --- a/main/gcc/dwarf2out.c +++ b/main/gcc/dwarf2out.c @@ -71,6 +71,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "hard-reg-set.h" #include "regs.h" +#include "rtlhash.h" #include "insn-config.h" #include "reload.h" #include "function.h" @@ -3278,7 +3279,7 @@ static void gen_scheduled_generic_parms_dies (void); static const char *comp_dir_string (void); -static hashval_t hash_loc_operands (dw_loc_descr_ref, hashval_t); +static void hash_loc_operands (dw_loc_descr_ref, inchash::hash &); /* enum for tracking thread-local variables whose address is really an offset relative to the TLS pointer, which will need link-time relocation, but will @@ -4191,17 +4192,22 @@ static hashval_t addr_table_entry_do_hash (const void *x) { const addr_table_entry *a = (const addr_table_entry *) x; + inchash::hash hstate; switch (a->kind) { case ate_kind_rtx: - return iterative_hash_rtx (a->addr.rtl, 0); + hstate.add_int (0); + break; case ate_kind_rtx_dtprel: - return iterative_hash_rtx (a->addr.rtl, 1); + hstate.add_int (1); + break; case ate_kind_label: return htab_hash_string (a->addr.label); default: gcc_unreachable (); } + inchash::add_rtx (a->addr.rtl, hstate); + return hstate.end (); } /* Determine equality for two address_table_entries. */ @@ -5545,11 +5551,13 @@ static inline void loc_checksum (dw_loc_descr_ref loc, struct md5_ctx *ctx) { int tem; - hashval_t hash = 0; + inchash::hash hstate; + hashval_t hash; tem = (loc->dtprel << 8) | ((unsigned int) loc->dw_loc_opc); CHECKSUM (tem); - hash = hash_loc_operands (loc, hash); + hash_loc_operands (loc, hstate); + hash = hstate.end(); CHECKSUM (hash); } @@ -5759,11 +5767,13 @@ loc_checksum_ordered (dw_loc_descr_ref loc, struct md5_ctx *ctx) /* Otherwise, just checksum the raw location expression. */ while (loc != NULL) { - hashval_t hash = 0; + inchash::hash hstate; + hashval_t hash; CHECKSUM_ULEB128 (loc->dtprel); CHECKSUM_ULEB128 (loc->dw_loc_opc); - hash = hash_loc_operands (loc, hash); + hash_loc_operands (loc, hstate); + hash = hstate.end (); CHECKSUM (hash); loc = loc->dw_loc_next; } @@ -23661,10 +23671,10 @@ resolve_addr (dw_die_ref die) This pass tries to share identical local lists in .debug_loc section. */ -/* Iteratively hash operands of LOC opcode. */ +/* Iteratively hash operands of LOC opcode into HSTATE. */ -static hashval_t -hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) +static void +hash_loc_operands (dw_loc_descr_ref loc, inchash::hash &hstate) { dw_val_ref val1 = &loc->dw_loc_oprnd1; dw_val_ref val2 = &loc->dw_loc_oprnd2; @@ -23723,7 +23733,7 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) case DW_OP_piece: case DW_OP_deref_size: case DW_OP_xderef_size: - hash = iterative_hash_object (val1->v.val_int, hash); + hstate.add_object (val1->v.val_int); break; case DW_OP_skip: case DW_OP_bra: @@ -23732,36 +23742,35 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) gcc_assert (val1->val_class == dw_val_class_loc); offset = val1->v.val_loc->dw_loc_addr - (loc->dw_loc_addr + 3); - hash = iterative_hash_object (offset, hash); + hstate.add_object (offset); } break; case DW_OP_implicit_value: - hash = iterative_hash_object (val1->v.val_unsigned, hash); + hstate.add_object (val1->v.val_unsigned); switch (val2->val_class) { case dw_val_class_const: - hash = iterative_hash_object (val2->v.val_int, hash); + hstate.add_object (val2->v.val_int); break; case dw_val_class_vec: { unsigned int elt_size = val2->v.val_vec.elt_size; unsigned int len = val2->v.val_vec.length; - hash = iterative_hash_object (elt_size, hash); - hash = iterative_hash_object (len, hash); - hash = iterative_hash (val2->v.val_vec.array, - len * elt_size, hash); + hstate.add_int (elt_size); + hstate.add_int (len); + hstate.add (val2->v.val_vec.array, len * elt_size); } break; case dw_val_class_const_double: - hash = iterative_hash_object (val2->v.val_double.low, hash); - hash = iterative_hash_object (val2->v.val_double.high, hash); + hstate.add_object (val2->v.val_double.low); + hstate.add_object (val2->v.val_double.high); break; case dw_val_class_wide_int: - hash = iterative_hash_object (*val2->v.val_wide, hash); + hstate.add_object (*val2->v.val_wide); break; - case dw_val_class_addr: - hash = iterative_hash_rtx (val2->v.val_addr, hash); + case dw_val_class_addr: + inchash::add_rtx (val2->v.val_addr, hstate); break; default: gcc_unreachable (); @@ -23769,17 +23778,17 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) break; case DW_OP_bregx: case DW_OP_bit_piece: - hash = iterative_hash_object (val1->v.val_int, hash); - hash = iterative_hash_object (val2->v.val_int, hash); + hstate.add_object (val1->v.val_int); + hstate.add_object (val2->v.val_int); break; case DW_OP_addr: hash_addr: if (loc->dtprel) { unsigned char dtprel = 0xd1; - hash = iterative_hash_object (dtprel, hash); + hstate.add_object (dtprel); } - hash = iterative_hash_rtx (val1->v.val_addr, hash); + inchash::add_rtx (val1->v.val_addr, hstate); break; case DW_OP_GNU_addr_index: case DW_OP_GNU_const_index: @@ -23787,16 +23796,16 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) if (loc->dtprel) { unsigned char dtprel = 0xd1; - hash = iterative_hash_object (dtprel, hash); + hstate.add_object (dtprel); } - hash = iterative_hash_rtx (val1->val_entry->addr.rtl, hash); + inchash::add_rtx (val1->val_entry->addr.rtl, hstate); } break; case DW_OP_GNU_implicit_pointer: - hash = iterative_hash_object (val2->v.val_int, hash); + hstate.add_int (val2->v.val_int); break; case DW_OP_GNU_entry_value: - hash = hash_loc_operands (val1->v.val_loc, hash); + hstate.add_object (val1->v.val_loc); break; case DW_OP_GNU_regval_type: case DW_OP_GNU_deref_type: @@ -23805,16 +23814,16 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) = get_AT_unsigned (val2->v.val_die_ref.die, DW_AT_byte_size); unsigned int encoding = get_AT_unsigned (val2->v.val_die_ref.die, DW_AT_encoding); - hash = iterative_hash_object (val1->v.val_int, hash); - hash = iterative_hash_object (byte_size, hash); - hash = iterative_hash_object (encoding, hash); + hstate.add_object (val1->v.val_int); + hstate.add_object (byte_size); + hstate.add_object (encoding); } break; case DW_OP_GNU_convert: case DW_OP_GNU_reinterpret: if (val1->val_class == dw_val_class_unsigned_const) { - hash = iterative_hash_object (val1->v.val_unsigned, hash); + hstate.add_object (val1->v.val_unsigned); break; } /* FALLTHRU */ @@ -23824,33 +23833,32 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) = get_AT_unsigned (val1->v.val_die_ref.die, DW_AT_byte_size); unsigned int encoding = get_AT_unsigned (val1->v.val_die_ref.die, DW_AT_encoding); - hash = iterative_hash_object (byte_size, hash); - hash = iterative_hash_object (encoding, hash); + hstate.add_object (byte_size); + hstate.add_object (encoding); if (loc->dw_loc_opc != DW_OP_GNU_const_type) break; - hash = iterative_hash_object (val2->val_class, hash); + hstate.add_object (val2->val_class); switch (val2->val_class) { case dw_val_class_const: - hash = iterative_hash_object (val2->v.val_int, hash); + hstate.add_object (val2->v.val_int); break; case dw_val_class_vec: { unsigned int elt_size = val2->v.val_vec.elt_size; unsigned int len = val2->v.val_vec.length; - hash = iterative_hash_object (elt_size, hash); - hash = iterative_hash_object (len, hash); - hash = iterative_hash (val2->v.val_vec.array, - len * elt_size, hash); + hstate.add_object (elt_size); + hstate.add_object (len); + hstate.add (val2->v.val_vec.array, len * elt_size); } break; case dw_val_class_const_double: - hash = iterative_hash_object (val2->v.val_double.low, hash); - hash = iterative_hash_object (val2->v.val_double.high, hash); + hstate.add_object (val2->v.val_double.low); + hstate.add_object (val2->v.val_double.high); break; case dw_val_class_wide_int: - hash = iterative_hash_object (*val2->v.val_wide, hash); + hstate.add_object (*val2->v.val_wide); break; default: gcc_unreachable (); @@ -23862,13 +23870,12 @@ hash_loc_operands (dw_loc_descr_ref loc, hashval_t hash) /* Other codes have no operands. */ break; } - return hash; } -/* Iteratively hash the whole DWARF location expression LOC. */ +/* Iteratively hash the whole DWARF location expression LOC into HSTATE. */ -static inline hashval_t -hash_locs (dw_loc_descr_ref loc, hashval_t hash) +static inline void +hash_locs (dw_loc_descr_ref loc, inchash::hash &hstate) { dw_loc_descr_ref l; bool sizes_computed = false; @@ -23878,15 +23885,14 @@ hash_locs (dw_loc_descr_ref loc, hashval_t hash) for (l = loc; l != NULL; l = l->dw_loc_next) { enum dwarf_location_atom opc = l->dw_loc_opc; - hash = iterative_hash_object (opc, hash); + hstate.add_object (opc); if ((opc == DW_OP_skip || opc == DW_OP_bra) && !sizes_computed) { size_of_locs (loc); sizes_computed = true; } - hash = hash_loc_operands (l, hash); + hash_loc_operands (l, hstate); } - return hash; } /* Compute hash of the whole location list LIST_HEAD. */ @@ -23895,18 +23901,17 @@ static inline void hash_loc_list (dw_loc_list_ref list_head) { dw_loc_list_ref curr = list_head; - hashval_t hash = 0; + inchash::hash hstate; for (curr = list_head; curr != NULL; curr = curr->dw_loc_next) { - hash = iterative_hash (curr->begin, strlen (curr->begin) + 1, hash); - hash = iterative_hash (curr->end, strlen (curr->end) + 1, hash); + hstate.add (curr->begin, strlen (curr->begin) + 1); + hstate.add (curr->end, strlen (curr->end) + 1); if (curr->section) - hash = iterative_hash (curr->section, strlen (curr->section) + 1, - hash); - hash = hash_locs (curr->expr, hash); + hstate.add (curr->section, strlen (curr->section) + 1); + hash_locs (curr->expr, hstate); } - list_head->hash = hash; + list_head->hash = hstate.end (); } /* Return true if X and Y opcodes have the same operands. */ diff --git a/main/gcc/except.c b/main/gcc/except.c index d1cfcbf5f09..67be5646a0f 100644 --- a/main/gcc/except.c +++ b/main/gcc/except.c @@ -527,7 +527,7 @@ struct duplicate_eh_regions_data { duplicate_eh_regions_map label_map; void *label_map_data; - struct pointer_map_t *eh_map; + hash_map *eh_map; }; static void @@ -536,12 +536,9 @@ duplicate_eh_regions_1 (struct duplicate_eh_regions_data *data, { eh_landing_pad old_lp, new_lp; eh_region new_r; - void **slot; new_r = gen_eh_region (old_r->type, outer); - slot = pointer_map_insert (data->eh_map, (void *)old_r); - gcc_assert (*slot == NULL); - *slot = (void *)new_r; + gcc_assert (!data->eh_map->put (old_r, new_r)); switch (old_r->type) { @@ -586,9 +583,7 @@ duplicate_eh_regions_1 (struct duplicate_eh_regions_data *data, continue; new_lp = gen_eh_landing_pad (new_r); - slot = pointer_map_insert (data->eh_map, (void *)old_lp); - gcc_assert (*slot == NULL); - *slot = (void *)new_lp; + gcc_assert (!data->eh_map->put (old_lp, new_lp)); new_lp->post_landing_pad = data->label_map (old_lp->post_landing_pad, data->label_map_data); @@ -609,7 +604,7 @@ duplicate_eh_regions_1 (struct duplicate_eh_regions_data *data, that allows the caller to remap uses of both EH regions and EH landing pads. */ -struct pointer_map_t * +hash_map * duplicate_eh_regions (struct function *ifun, eh_region copy_region, int outer_lp, duplicate_eh_regions_map map, void *map_data) @@ -623,7 +618,7 @@ duplicate_eh_regions (struct function *ifun, data.label_map = map; data.label_map_data = map_data; - data.eh_map = pointer_map_create (); + data.eh_map = new hash_map; outer_region = get_eh_region_from_lp_number (outer_lp); diff --git a/main/gcc/except.h b/main/gcc/except.h index bab13e10cbe..5c2aa3de939 100644 --- a/main/gcc/except.h +++ b/main/gcc/except.h @@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. If not see # define GCC_EXCEPT_H #endif +#include "hash-map.h" #include "hashtab.h" struct function; @@ -249,7 +250,7 @@ extern rtx expand_builtin_extend_pointer (tree); extern void expand_dw2_landing_pad_for_region (eh_region); typedef tree (*duplicate_eh_regions_map) (tree, void *); -extern struct pointer_map_t *duplicate_eh_regions +extern hash_map *duplicate_eh_regions (struct function *, eh_region, int, duplicate_eh_regions_map, void *); extern void sjlj_emit_function_exit_after (rtx); diff --git a/main/gcc/explow.c b/main/gcc/explow.c index e39db0507db..92c4e574dcb 100644 --- a/main/gcc/explow.c +++ b/main/gcc/explow.c @@ -518,8 +518,9 @@ memory_address_addr_space (enum machine_mode mode, rtx x, addr_space_t as) return x; } -/* Convert a mem ref into one with a valid memory address. - Pass through anything else unchanged. */ +/* If REF is a MEM with an invalid address, change it into a valid address. + Pass through anything else unchanged. REF must be an unshared rtx and + the function may modify it in-place. */ rtx validize_mem (rtx ref) @@ -531,8 +532,7 @@ validize_mem (rtx ref) MEM_ADDR_SPACE (ref))) return ref; - /* Don't alter REF itself, since that is probably a stack slot. */ - return replace_equiv_address (ref, XEXP (ref, 0)); + return replace_equiv_address (ref, XEXP (ref, 0), true); } /* If X is a memory reference to a member of an object block, try rewriting diff --git a/main/gcc/flag-types.h b/main/gcc/flag-types.h index 2849455d793..135c3434bbf 100644 --- a/main/gcc/flag-types.h +++ b/main/gcc/flag-types.h @@ -214,27 +214,30 @@ enum vect_cost_model { enum sanitize_code { /* AddressSanitizer. */ SANITIZE_ADDRESS = 1 << 0, + SANITIZE_USER_ADDRESS = 1 << 1, + SANITIZE_KERNEL_ADDRESS = 1 << 2, /* ThreadSanitizer. */ - SANITIZE_THREAD = 1 << 1, + SANITIZE_THREAD = 1 << 3, /* LeakSanitizer. */ - SANITIZE_LEAK = 1 << 2, + SANITIZE_LEAK = 1 << 4, /* UndefinedBehaviorSanitizer. */ - SANITIZE_SHIFT = 1 << 3, - SANITIZE_DIVIDE = 1 << 4, - SANITIZE_UNREACHABLE = 1 << 5, - SANITIZE_VLA = 1 << 6, - SANITIZE_NULL = 1 << 7, - SANITIZE_RETURN = 1 << 8, - SANITIZE_SI_OVERFLOW = 1 << 9, - SANITIZE_BOOL = 1 << 10, - SANITIZE_ENUM = 1 << 11, - SANITIZE_FLOAT_DIVIDE = 1 << 12, - SANITIZE_FLOAT_CAST = 1 << 13, - SANITIZE_BOUNDS = 1 << 14, + SANITIZE_SHIFT = 1 << 5, + SANITIZE_DIVIDE = 1 << 6, + SANITIZE_UNREACHABLE = 1 << 7, + SANITIZE_VLA = 1 << 8, + SANITIZE_NULL = 1 << 9, + SANITIZE_RETURN = 1 << 10, + SANITIZE_SI_OVERFLOW = 1 << 11, + SANITIZE_BOOL = 1 << 12, + SANITIZE_ENUM = 1 << 13, + SANITIZE_FLOAT_DIVIDE = 1 << 14, + SANITIZE_FLOAT_CAST = 1 << 15, + SANITIZE_BOUNDS = 1 << 16, + SANITIZE_ALIGNMENT = 1 << 17, SANITIZE_UNDEFINED = SANITIZE_SHIFT | SANITIZE_DIVIDE | SANITIZE_UNREACHABLE | SANITIZE_VLA | SANITIZE_NULL | SANITIZE_RETURN | SANITIZE_SI_OVERFLOW | SANITIZE_BOOL | SANITIZE_ENUM - | SANITIZE_BOUNDS, + | SANITIZE_BOUNDS | SANITIZE_ALIGNMENT, SANITIZE_NONDEFAULT = SANITIZE_FLOAT_DIVIDE | SANITIZE_FLOAT_CAST }; diff --git a/main/gcc/fold-const.c b/main/gcc/fold-const.c index a449f51427b..49ab04265a5 100644 --- a/main/gcc/fold-const.c +++ b/main/gcc/fold-const.c @@ -7270,15 +7270,18 @@ fold_plusminus_mult_expr (location_t loc, enum tree_code code, tree type, upon failure. */ static int -native_encode_int (const_tree expr, unsigned char *ptr, int len) +native_encode_int (const_tree expr, unsigned char *ptr, int len, int off) { tree type = TREE_TYPE (expr); int total_bytes = GET_MODE_SIZE (TYPE_MODE (type)); int byte, offset, word, words; unsigned char value; - if (total_bytes > len) + if ((off == -1 && total_bytes > len) + || off >= total_bytes) return 0; + if (off == -1) + off = 0; words = total_bytes / UNITS_PER_WORD; for (byte = 0; byte < total_bytes; byte++) @@ -7301,9 +7304,11 @@ native_encode_int (const_tree expr, unsigned char *ptr, int len) } else offset = BYTES_BIG_ENDIAN ? (total_bytes - 1) - byte : byte; - ptr[offset] = value; + if (offset >= off + && offset - off < len) + ptr[offset - off] = value; } - return total_bytes; + return MIN (len, total_bytes - off); } @@ -7313,7 +7318,7 @@ native_encode_int (const_tree expr, unsigned char *ptr, int len) upon failure. */ static int -native_encode_fixed (const_tree expr, unsigned char *ptr, int len) +native_encode_fixed (const_tree expr, unsigned char *ptr, int len, int off) { tree type = TREE_TYPE (expr); enum machine_mode mode = TYPE_MODE (type); @@ -7333,7 +7338,7 @@ native_encode_fixed (const_tree expr, unsigned char *ptr, int len) value = TREE_FIXED_CST (expr); i_value = double_int_to_tree (i_type, value.data); - return native_encode_int (i_value, ptr, len); + return native_encode_int (i_value, ptr, len, off); } @@ -7343,7 +7348,7 @@ native_encode_fixed (const_tree expr, unsigned char *ptr, int len) upon failure. */ static int -native_encode_real (const_tree expr, unsigned char *ptr, int len) +native_encode_real (const_tree expr, unsigned char *ptr, int len, int off) { tree type = TREE_TYPE (expr); int total_bytes = GET_MODE_SIZE (TYPE_MODE (type)); @@ -7355,8 +7360,11 @@ native_encode_real (const_tree expr, unsigned char *ptr, int len) up to 192 bits. */ long tmp[6]; - if (total_bytes > len) + if ((off == -1 && total_bytes > len) + || off >= total_bytes) return 0; + if (off == -1) + off = 0; words = (32 / BITS_PER_UNIT) / UNITS_PER_WORD; real_to_target (tmp, TREE_REAL_CST_PTR (expr), TYPE_MODE (type)); @@ -7380,9 +7388,12 @@ native_encode_real (const_tree expr, unsigned char *ptr, int len) } else offset = BYTES_BIG_ENDIAN ? 3 - byte : byte; - ptr[offset + ((bitpos / BITS_PER_UNIT) & ~3)] = value; + offset = offset + ((bitpos / BITS_PER_UNIT) & ~3); + if (offset >= off + && offset - off < len) + ptr[offset - off] = value; } - return total_bytes; + return MIN (len, total_bytes - off); } /* Subroutine of native_encode_expr. Encode the COMPLEX_CST @@ -7391,18 +7402,22 @@ native_encode_real (const_tree expr, unsigned char *ptr, int len) upon failure. */ static int -native_encode_complex (const_tree expr, unsigned char *ptr, int len) +native_encode_complex (const_tree expr, unsigned char *ptr, int len, int off) { int rsize, isize; tree part; part = TREE_REALPART (expr); - rsize = native_encode_expr (part, ptr, len); - if (rsize == 0) + rsize = native_encode_expr (part, ptr, len, off); + if (off == -1 + && rsize == 0) return 0; part = TREE_IMAGPART (expr); - isize = native_encode_expr (part, ptr+rsize, len-rsize); - if (isize != rsize) + if (off != -1) + off = MAX (0, off - GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (part)))); + isize = native_encode_expr (part, ptr+rsize, len-rsize, off); + if (off == -1 + && isize != rsize) return 0; return rsize + isize; } @@ -7414,7 +7429,7 @@ native_encode_complex (const_tree expr, unsigned char *ptr, int len) upon failure. */ static int -native_encode_vector (const_tree expr, unsigned char *ptr, int len) +native_encode_vector (const_tree expr, unsigned char *ptr, int len, int off) { unsigned i, count; int size, offset; @@ -7426,10 +7441,21 @@ native_encode_vector (const_tree expr, unsigned char *ptr, int len) size = GET_MODE_SIZE (TYPE_MODE (itype)); for (i = 0; i < count; i++) { + if (off >= size) + { + off -= size; + continue; + } elem = VECTOR_CST_ELT (expr, i); - if (native_encode_expr (elem, ptr+offset, len-offset) != size) + int res = native_encode_expr (elem, ptr+offset, len-offset, off); + if ((off == -1 && res != size) + || res == 0) return 0; - offset += size; + offset += res; + if (offset >= len) + return offset; + if (off != -1) + off = 0; } return offset; } @@ -7441,7 +7467,7 @@ native_encode_vector (const_tree expr, unsigned char *ptr, int len) upon failure. */ static int -native_encode_string (const_tree expr, unsigned char *ptr, int len) +native_encode_string (const_tree expr, unsigned char *ptr, int len, int off) { tree type = TREE_TYPE (expr); HOST_WIDE_INT total_bytes; @@ -7452,47 +7478,56 @@ native_encode_string (const_tree expr, unsigned char *ptr, int len) || !tree_fits_shwi_p (TYPE_SIZE_UNIT (type))) return 0; total_bytes = tree_to_shwi (TYPE_SIZE_UNIT (type)); - if (total_bytes > len) + if ((off == -1 && total_bytes > len) + || off >= total_bytes) return 0; - if (TREE_STRING_LENGTH (expr) < total_bytes) + if (off == -1) + off = 0; + if (TREE_STRING_LENGTH (expr) - off < MIN (total_bytes, len)) { - memcpy (ptr, TREE_STRING_POINTER (expr), TREE_STRING_LENGTH (expr)); - memset (ptr + TREE_STRING_LENGTH (expr), 0, - total_bytes - TREE_STRING_LENGTH (expr)); + int written = 0; + if (off < TREE_STRING_LENGTH (expr)) + { + written = MIN (len, TREE_STRING_LENGTH (expr) - off); + memcpy (ptr, TREE_STRING_POINTER (expr) + off, written); + } + memset (ptr + written, 0, + MIN (total_bytes - written, len - written)); } else - memcpy (ptr, TREE_STRING_POINTER (expr), total_bytes); - return total_bytes; + memcpy (ptr, TREE_STRING_POINTER (expr) + off, MIN (total_bytes, len)); + return MIN (total_bytes - off, len); } /* Subroutine of fold_view_convert_expr. Encode the INTEGER_CST, REAL_CST, COMPLEX_CST or VECTOR_CST specified by EXPR into the - buffer PTR of length LEN bytes. Return the number of bytes - placed in the buffer, or zero upon failure. */ + buffer PTR of length LEN bytes. If OFF is not -1 then start + the encoding at byte offset OFF and encode at most LEN bytes. + Return the number of bytes placed in the buffer, or zero upon failure. */ int -native_encode_expr (const_tree expr, unsigned char *ptr, int len) +native_encode_expr (const_tree expr, unsigned char *ptr, int len, int off) { switch (TREE_CODE (expr)) { case INTEGER_CST: - return native_encode_int (expr, ptr, len); + return native_encode_int (expr, ptr, len, off); case REAL_CST: - return native_encode_real (expr, ptr, len); + return native_encode_real (expr, ptr, len, off); case FIXED_CST: - return native_encode_fixed (expr, ptr, len); + return native_encode_fixed (expr, ptr, len, off); case COMPLEX_CST: - return native_encode_complex (expr, ptr, len); + return native_encode_complex (expr, ptr, len, off); case VECTOR_CST: - return native_encode_vector (expr, ptr, len); + return native_encode_vector (expr, ptr, len, off); case STRING_CST: - return native_encode_string (expr, ptr, len); + return native_encode_string (expr, ptr, len, off); default: return 0; @@ -9065,9 +9100,13 @@ fold_comparison (location_t loc, enum tree_code code, tree type, /* Transform comparisons of the form X - Y CMP 0 to X CMP Y. */ if (TREE_CODE (arg0) == MINUS_EXPR - && (equality_code || TYPE_OVERFLOW_UNDEFINED (TREE_TYPE (arg0))) + && equality_code && integer_zerop (arg1)) { + /* ??? The transformation is valid for the other operators if overflow + is undefined for the type, but performing it here badly interacts + with the transformation in fold_cond_expr_with_comparison which + attempts to synthetize ABS_EXPR. */ if (!equality_code) fold_overflow_warning ("assuming signed overflow does not occur " "when changing X - Y cmp 0 to X cmp Y", diff --git a/main/gcc/fold-const.h b/main/gcc/fold-const.h index 3b5fd8476d6..b440ca11881 100644 --- a/main/gcc/fold-const.h +++ b/main/gcc/fold-const.h @@ -25,7 +25,7 @@ along with GCC; see the file COPYING3. If not see extern int folding_initializer; /* Convert between trees and native memory representation. */ -extern int native_encode_expr (const_tree, unsigned char *, int); +extern int native_encode_expr (const_tree, unsigned char *, int, int off = -1); extern tree native_interpret_expr (tree, const unsigned char *, int); /* Fold constants as much as possible in an expression. diff --git a/main/gcc/fortran/ChangeLog b/main/gcc/fortran/ChangeLog index c33936b3664..baf8d5348ed 100644 --- a/main/gcc/fortran/ChangeLog +++ b/main/gcc/fortran/ChangeLog @@ -1,9 +1,47 @@ +2014-08-02 Trevor Saunders + + * openmp.c, trans-decl.c: Use hash_set instead of pointer_set. + +2014-07-26 Tobias Burnus + + PR fortran/61881 + PR fortran/61888 + PR fortran/57305 + * intrinsic.texi (SIZEOF): Document changed behavior + for polymorphic arrays. + +2014-07-26 Tobias Burnus + + PR fortran/61881 + PR fortran/61888 + PR fortran/57305 + * check.c (gfc_check_sizeof): Permit for assumed type if and + only if it has an array descriptor. + * intrinsic.c (do_ts29113_check): Permit SIZEOF. + (add_functions): SIZEOF is an Inquiry function. + * intrinsic.texi (SIZEOF): Add note that only contiguous + arrays are permitted. + * trans-expr.c (gfc_conv_intrinsic_to_class): Handle assumed + rank. + * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle + assumed type + array descriptor, CLASS and assumed rank. + (gfc_conv_intrinsic_storage_size): Handle class arrays. + +2014-07-25 Tobias Burnus + + * simplify.c (gfc_simplify_storage_size): Use proper + integer kind for the returned value. + +2014-07-24 Uros Bizjak + + * intrinsic.texi (Intrinsic Procedures) : Move to + correct menu position to match sectioning. + 2014-06-15 Tobias Burnus * symbol.c (check_conflict): Add codimension conflict with pointer; fix cray-pointee check. - 2014-06-14 Tobias Burnus * trans-intrinsic.c (conv_intrinsic_atomic_ref): Fix handling diff --git a/main/gcc/fortran/check.c b/main/gcc/fortran/check.c index eff2c4c78a7..95d28693f27 100644 --- a/main/gcc/fortran/check.c +++ b/main/gcc/fortran/check.c @@ -3902,7 +3902,12 @@ gfc_check_sizeof (gfc_expr *arg) return false; } - if (arg->ts.type == BT_ASSUMED) + /* TYPE(*) is acceptable if and only if it uses an array descriptor. */ + if (arg->ts.type == BT_ASSUMED + && (arg->symtree->n.sym->as == NULL + || (arg->symtree->n.sym->as->type != AS_ASSUMED_SHAPE + && arg->symtree->n.sym->as->type != AS_DEFERRED + && arg->symtree->n.sym->as->type != AS_ASSUMED_RANK))) { gfc_error ("'%s' argument of '%s' intrinsic at %L shall not be TYPE(*)", gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic, diff --git a/main/gcc/fortran/intrinsic.c b/main/gcc/fortran/intrinsic.c index d681d702822..1ad1e692135 100644 --- a/main/gcc/fortran/intrinsic.c +++ b/main/gcc/fortran/intrinsic.c @@ -204,6 +204,7 @@ do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) && specific->id != GFC_ISYM_RANK && specific->id != GFC_ISYM_SHAPE && specific->id != GFC_ISYM_SIZE + && specific->id != GFC_ISYM_SIZEOF && specific->id != GFC_ISYM_UBOUND && specific->id != GFC_ISYM_C_LOC) { @@ -2765,8 +2766,9 @@ add_functions (void) ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_from_module(); - add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, - GFC_STD_GNU, gfc_check_sizeof, gfc_simplify_sizeof, NULL, + add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, + BT_INTEGER, ii, GFC_STD_GNU, + gfc_check_sizeof, gfc_simplify_sizeof, NULL, x, BT_UNKNOWN, 0, REQUIRED); make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU); diff --git a/main/gcc/fortran/intrinsic.texi b/main/gcc/fortran/intrinsic.texi index 2cf6dfe4415..0f4a8a7021f 100644 --- a/main/gcc/fortran/intrinsic.texi +++ b/main/gcc/fortran/intrinsic.texi @@ -63,12 +63,12 @@ Some basic guidelines for editing this document: * @code{ATOMIC_ADD}: ATOMIC_ADD, Atomic ADD operation * @code{ATOMIC_AND}: ATOMIC_AND, Atomic bitwise AND operation * @code{ATOMIC_CAS}: ATOMIC_CAS, Atomic compare and swap +* @code{ATOMIC_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically * @code{ATOMIC_FETCH_ADD}: ATOMIC_FETCH_ADD, Atomic ADD operation with prior fetch * @code{ATOMIC_FETCH_AND}: ATOMIC_FETCH_AND, Atomic bitwise AND operation with prior fetch * @code{ATOMIC_FETCH_OR}: ATOMIC_FETCH_OR, Atomic bitwise OR operation with prior fetch * @code{ATOMIC_FETCH_XOR}: ATOMIC_FETCH_XOR, Atomic bitwise XOR operation with prior fetch * @code{ATOMIC_OR}: ATOMIC_OR, Atomic bitwise OR operation -* @code{ATOMIC_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically * @code{ATOMIC_REF}: ATOMIC_REF, Obtaining the value of a variable atomically * @code{ATOMIC_XOR}: ATOMIC_XOR, Atomic bitwise OR operation * @code{BACKTRACE}: BACKTRACE, Show a backtrace @@ -12204,8 +12204,10 @@ number of bytes occupied by the argument. If the argument has the to is returned. If the argument is of a derived type with @code{POINTER} or @code{ALLOCATABLE} components, the return value does not account for the sizes of the data pointed to by these components. If the argument is -polymorphic, the size according to the declared type is returned. The argument -may not be a procedure or procedure pointer. +polymorphic, the size according to the dynamic type is returned. The argument +may not be a procedure or procedure pointer. Note that the code assumes for +arrays that those are contiguous; for contiguous arrays, it returns the +storage or an array element multiplied by the size of the array. @item @emph{Example}: @smallexample diff --git a/main/gcc/fortran/openmp.c b/main/gcc/fortran/openmp.c index 68ba70f7ebe..410efb11c49 100644 --- a/main/gcc/fortran/openmp.c +++ b/main/gcc/fortran/openmp.c @@ -26,7 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "parse.h" -#include "pointer-set.h" +#include "hash-set.h" /* Match an end of OpenMP directive. End of OpenMP directive is optional whitespace, followed by '\n' or comment '!'. */ @@ -3013,8 +3013,8 @@ resolve_omp_atomic (gfc_code *code) struct omp_context { gfc_code *code; - struct pointer_set_t *sharing_clauses; - struct pointer_set_t *private_iterators; + hash_set *sharing_clauses; + hash_set *private_iterators; struct omp_context *previous; } *omp_current_ctx; static gfc_code *omp_current_do_code; @@ -3057,8 +3057,8 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) int list; ctx.code = code; - ctx.sharing_clauses = pointer_set_create (); - ctx.private_iterators = pointer_set_create (); + ctx.sharing_clauses = new hash_set; + ctx.private_iterators = new hash_set; ctx.previous = omp_current_ctx; omp_current_ctx = &ctx; @@ -3072,7 +3072,7 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) case OMP_LIST_REDUCTION: case OMP_LIST_LINEAR: for (n = omp_clauses->lists[list]; n; n = n->next) - pointer_set_insert (ctx.sharing_clauses, n->sym); + ctx.sharing_clauses->add (n->sym); break; default: break; @@ -3097,8 +3097,8 @@ gfc_resolve_omp_parallel_blocks (gfc_code *code, gfc_namespace *ns) } omp_current_ctx = ctx.previous; - pointer_set_destroy (ctx.sharing_clauses); - pointer_set_destroy (ctx.private_iterators); + delete ctx.sharing_clauses; + delete ctx.private_iterators; } @@ -3154,10 +3154,10 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym) if (omp_current_ctx == NULL) return; - if (pointer_set_contains (omp_current_ctx->sharing_clauses, sym)) + if (omp_current_ctx->sharing_clauses->contains (sym)) return; - if (! pointer_set_insert (omp_current_ctx->private_iterators, sym)) + if (! omp_current_ctx->private_iterators->add (sym)) { gfc_omp_clauses *omp_clauses = omp_current_ctx->code->ext.omp_clauses; gfc_omp_namelist *p; diff --git a/main/gcc/fortran/simplify.c b/main/gcc/fortran/simplify.c index 60d85934b72..d4a67ada3da 100644 --- a/main/gcc/fortran/simplify.c +++ b/main/gcc/fortran/simplify.c @@ -5841,11 +5841,9 @@ gfc_simplify_storage_size (gfc_expr *x, if (k == -1) return &gfc_bad_expr; - result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, - &x->where); + result = gfc_get_constant_expr (BT_INTEGER, k, &x->where); mpz_set_si (result->value.integer, gfc_element_size (x)); - mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT); return range_check (result, "STORAGE_SIZE"); diff --git a/main/gcc/fortran/trans-decl.c b/main/gcc/fortran/trans-decl.c index 8b56151ca69..babe48f56a2 100644 --- a/main/gcc/fortran/trans-decl.c +++ b/main/gcc/fortran/trans-decl.c @@ -40,7 +40,7 @@ along with GCC; see the file COPYING3. If not see #include "cgraph.h" #include "debug.h" #include "gfortran.h" -#include "pointer-set.h" +#include "hash-set.h" #include "constructor.h" #include "trans.h" #include "trans-types.h" @@ -63,7 +63,7 @@ static GTY(()) tree parent_fake_result_decl; static GTY(()) tree saved_function_decls; static GTY(()) tree saved_parent_function_decls; -static struct pointer_set_t *nonlocal_dummy_decl_pset; +static hash_set *nonlocal_dummy_decl_pset; static GTY(()) tree nonlocal_dummy_decls; /* Holds the variable DECLs that are locals. */ @@ -1094,9 +1094,9 @@ gfc_nonlocal_dummy_array_decl (gfc_symbol *sym) tree decl, dummy; if (! nonlocal_dummy_decl_pset) - nonlocal_dummy_decl_pset = pointer_set_create (); + nonlocal_dummy_decl_pset = new hash_set; - if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl)) + if (nonlocal_dummy_decl_pset->add (sym->backend_decl)) return; dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl); @@ -5861,7 +5861,7 @@ gfc_generate_function_code (gfc_namespace * ns) { BLOCK_VARS (DECL_INITIAL (fndecl)) = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls); - pointer_set_destroy (nonlocal_dummy_decl_pset); + delete nonlocal_dummy_decl_pset; nonlocal_dummy_decls = NULL; nonlocal_dummy_decl_pset = NULL; } diff --git a/main/gcc/fortran/trans-expr.c b/main/gcc/fortran/trans-expr.c index 81f21371177..02cec973c1a 100644 --- a/main/gcc/fortran/trans-expr.c +++ b/main/gcc/fortran/trans-expr.c @@ -564,7 +564,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, var = gfc_create_var (tmp, "class"); /* Set the vptr. */ - ctree = gfc_class_vptr_get (var); + ctree = gfc_class_vptr_get (var); vtab = gfc_find_vtab (&e->ts); gcc_assert (vtab); @@ -573,7 +573,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, fold_convert (TREE_TYPE (ctree), tmp)); /* Now set the data field. */ - ctree = gfc_class_data_get (var); + ctree = gfc_class_data_get (var); if (parmse->ss && parmse->ss->info->useflags) { /* For an array reference in an elemental procedure call we need @@ -589,7 +589,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, { parmse->ss = NULL; gfc_conv_expr_reference (parmse, e); - tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + if (class_ts.u.derived->components->as + && class_ts.u.derived->components->as->type == AS_ASSUMED_RANK) + { + tmp = gfc_conv_scalar_to_descriptor (parmse, parmse->expr, + gfc_expr_attr (e)); + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (ctree), tmp); + } + else + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); gfc_add_modify (&parmse->pre, ctree, tmp); } else @@ -597,7 +606,14 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e, parmse->ss = ss; parmse->use_offset = 1; gfc_conv_expr_descriptor (parmse, e); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); + if (class_ts.u.derived->components->as->rank != e->rank) + { + tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR, + TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + gfc_add_modify (&parmse->pre, ctree, parmse->expr); } } diff --git a/main/gcc/fortran/trans-intrinsic.c b/main/gcc/fortran/trans-intrinsic.c index 3de0b096759..9059878b9da 100644 --- a/main/gcc/fortran/trans-intrinsic.c +++ b/main/gcc/fortran/trans-intrinsic.c @@ -5891,62 +5891,131 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr) gfc_expr *arg; gfc_se argse; tree source_bytes; - tree type; tree tmp; tree lower; tree upper; + tree byte_size; int n; - arg = expr->value.function.actual->expr; - gfc_init_se (&argse, NULL); + arg = expr->value.function.actual->expr; - if (arg->rank == 0) + if (arg->rank || arg->ts.type == BT_ASSUMED) + gfc_conv_expr_descriptor (&argse, arg); + else + gfc_conv_expr_reference (&argse, arg); + + if (arg->ts.type == BT_ASSUMED) + { + /* This only works if an array descriptor has been passed; thus, extract + the size from the descriptor. */ + gcc_assert (TYPE_PRECISION (gfc_array_index_type) + == TYPE_PRECISION (size_type_node)); + tmp = arg->symtree->n.sym->backend_decl; + tmp = DECL_LANG_SPECIFIC (tmp) + && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE + ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp; + if (POINTER_TYPE_P (TREE_TYPE (tmp))) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp)); + tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp, + build_int_cst (TREE_TYPE (tmp), + GFC_DTYPE_SIZE_SHIFT)); + byte_size = fold_convert (gfc_array_index_type, tmp); + } + else if (arg->ts.type == BT_CLASS) + { + if (arg->rank) + byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); + else + byte_size = gfc_vtable_size_get (argse.expr); + } + else { - if (arg->ts.type == BT_CLASS) - gfc_add_data_component (arg); - - gfc_conv_expr_reference (&argse, arg); - - type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, - argse.expr)); - - /* Obtain the source word length. */ if (arg->ts.type == BT_CHARACTER) - se->expr = size_of_string_in_bytes (arg->ts.kind, - argse.string_length); + byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length); else - se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type)); + { + if (arg->rank == 0) + byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location, + argse.expr)); + else + byte_size = gfc_get_element_type (TREE_TYPE (argse.expr)); + byte_size = fold_convert (gfc_array_index_type, + size_in_bytes (byte_size)); + } } + + if (arg->rank == 0) + se->expr = byte_size; else { source_bytes = gfc_create_var (gfc_array_index_type, "bytes"); - argse.want_pointer = 0; - gfc_conv_expr_descriptor (&argse, arg); - type = gfc_get_element_type (TREE_TYPE (argse.expr)); + gfc_add_modify (&argse.pre, source_bytes, byte_size); - /* Obtain the argument's word length. */ - if (arg->ts.type == BT_CHARACTER) - tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length); - else - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (type)); - gfc_add_modify (&argse.pre, source_bytes, tmp); - - /* Obtain the size of the array in bytes. */ - for (n = 0; n < arg->rank; n++) + if (arg->rank == -1) { - tree idx; - idx = gfc_rank_cst[n]; - lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); - upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, tmp, gfc_index_one_node); + tree cond, loop_var, exit_label; + stmtblock_t body; + + tmp = fold_convert (gfc_array_index_type, + gfc_conv_descriptor_rank (argse.expr)); + loop_var = gfc_create_var (gfc_array_index_type, "i"); + gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node); + exit_label = gfc_build_label_decl (NULL_TREE); + + /* Create loop: + for (;;) + { + if (i >= rank) + goto exit; + source_bytes = source_bytes * array.dim[i].extent; + i = i + 1; + } + exit: */ + gfc_start_block (&body); + cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, + loop_var, tmp); + tmp = build1_v (GOTO_EXPR, exit_label); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var); + upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var); + tmp = gfc_conv_array_extent_dim (lower, upper, NULL); tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, tmp, source_bytes); - gfc_add_modify (&argse.pre, source_bytes, tmp); + gfc_add_modify (&body, source_bytes, tmp); + + tmp = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, loop_var, + gfc_index_one_node); + gfc_add_modify_loc (input_location, &body, loop_var, tmp); + + tmp = gfc_finish_block (&body); + + tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node, + tmp); + gfc_add_expr_to_block (&argse.pre, tmp); + + tmp = build1_v (LABEL_EXPR, exit_label); + gfc_add_expr_to_block (&argse.pre, tmp); + } + else + { + /* Obtain the size of the array in bytes. */ + for (n = 0; n < arg->rank; n++) + { + tree idx; + idx = gfc_rank_cst[n]; + lower = gfc_conv_descriptor_lbound_get (argse.expr, idx); + upper = gfc_conv_descriptor_ubound_get (argse.expr, idx); + tmp = gfc_conv_array_extent_dim (lower, upper, NULL); + tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, tmp, source_bytes); + gfc_add_modify (&argse.pre, source_bytes, tmp); + } } se->expr = source_bytes; } @@ -5970,13 +6039,13 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) if (arg->rank == 0) { if (arg->ts.type == BT_CLASS) - { - gfc_add_vptr_component (arg); - gfc_add_size_component (arg); - gfc_conv_expr (&argse, arg); - tmp = fold_convert (result_type, argse.expr); - goto done; - } + { + gfc_add_vptr_component (arg); + gfc_add_size_component (arg); + gfc_conv_expr (&argse, arg); + tmp = fold_convert (result_type, argse.expr); + goto done; + } gfc_conv_expr_reference (&argse, arg); type = TREE_TYPE (build_fold_indirect_ref_loc (input_location, @@ -5986,6 +6055,12 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr) { argse.want_pointer = 0; gfc_conv_expr_descriptor (&argse, arg); + if (arg->ts.type == BT_CLASS) + { + tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0)); + tmp = fold_convert (result_type, tmp); + goto done; + } type = gfc_get_element_type (TREE_TYPE (argse.expr)); } diff --git a/main/gcc/function.c b/main/gcc/function.c index f96e5ceb8be..5e04b8fd7fe 100644 --- a/main/gcc/function.c +++ b/main/gcc/function.c @@ -2663,13 +2663,14 @@ assign_parm_adjust_entry_rtl (struct assign_parm_data_one *data) /* Handle calls that pass values in multiple non-contiguous locations. The Irix 6 ABI has examples of this. */ if (GET_CODE (entry_parm) == PARALLEL) - emit_group_store (validize_mem (stack_parm), entry_parm, + emit_group_store (validize_mem (copy_rtx (stack_parm)), entry_parm, data->passed_type, int_size_in_bytes (data->passed_type)); else { gcc_assert (data->partial % UNITS_PER_WORD == 0); - move_block_from_reg (REGNO (entry_parm), validize_mem (stack_parm), + move_block_from_reg (REGNO (entry_parm), + validize_mem (copy_rtx (stack_parm)), data->partial / UNITS_PER_WORD); } @@ -2838,7 +2839,7 @@ assign_parm_setup_block (struct assign_parm_data_all *all, else gcc_assert (!size || !(PARM_BOUNDARY % BITS_PER_WORD)); - mem = validize_mem (stack_parm); + mem = validize_mem (copy_rtx (stack_parm)); /* Handle values in multiple non-contiguous locations. */ if (GET_CODE (entry_parm) == PARALLEL) @@ -2973,7 +2974,7 @@ assign_parm_setup_reg (struct assign_parm_data_all *all, tree parm, assign_parm_find_data_types and expand_expr_real_1. */ equiv_stack_parm = data->stack_parm; - validated_mem = validize_mem (data->entry_parm); + validated_mem = validize_mem (copy_rtx (data->entry_parm)); need_conversion = (data->nominal_mode != data->passed_mode || promoted_nominal_mode != data->promoted_mode); @@ -3229,7 +3230,7 @@ assign_parm_setup_stack (struct assign_parm_data_all *all, tree parm, /* Conversion is required. */ rtx tempreg = gen_reg_rtx (GET_MODE (data->entry_parm)); - emit_move_insn (tempreg, validize_mem (data->entry_parm)); + emit_move_insn (tempreg, validize_mem (copy_rtx (data->entry_parm))); push_to_sequence2 (all->first_conversion_insn, all->last_conversion_insn); to_conversion = true; @@ -3266,8 +3267,8 @@ assign_parm_setup_stack (struct assign_parm_data_all *all, tree parm, set_mem_attributes (data->stack_parm, parm, 1); } - dest = validize_mem (data->stack_parm); - src = validize_mem (data->entry_parm); + dest = validize_mem (copy_rtx (data->stack_parm)); + src = validize_mem (copy_rtx (data->entry_parm)); if (MEM_P (src)) { @@ -5280,7 +5281,7 @@ get_arg_pointer_save_area (void) generated stack slot may not be a valid memory address, so we have to check it and fix it if necessary. */ start_sequence (); - emit_move_insn (validize_mem (ret), + emit_move_insn (validize_mem (copy_rtx (ret)), crtl->args.internal_arg_pointer); seq = get_insns (); end_sequence (); diff --git a/main/gcc/gcc.c b/main/gcc/gcc.c index f7c91838b87..43e464a9a9b 100644 --- a/main/gcc/gcc.c +++ b/main/gcc/gcc.c @@ -779,8 +779,7 @@ proper position among the other output files. */ #ifndef SANITIZER_SPEC #define SANITIZER_SPEC "\ %{!nostdlib:%{!nodefaultlibs:%{%:sanitize(address):" LIBASAN_SPEC "\ - %{static:%ecannot specify -static with -fsanitize=address}\ - %{%:sanitize(thread):%e-fsanitize=address is incompatible with -fsanitize=thread}}\ + %{static:%ecannot specify -static with -fsanitize=address}}\ %{%:sanitize(thread):" LIBTSAN_SPEC "\ %{!pie:%{!shared:%e-fsanitize=thread linking must be done with -pie or -shared}}}\ %{%:sanitize(undefined):" LIBUBSAN_SPEC "}\ @@ -4911,7 +4910,7 @@ do_spec_1 (const char *spec, int inswitch, const char *soft_matched_part) { saved_suffix = XNEWVEC (char, suffix_length - + strlen (TARGET_OBJECT_SUFFIX)); + + strlen (TARGET_OBJECT_SUFFIX) + 1); strncpy (saved_suffix, suffix, suffix_length); strcpy (saved_suffix + suffix_length, TARGET_OBJECT_SUFFIX); @@ -8293,7 +8292,9 @@ sanitize_spec_function (int argc, const char **argv) return NULL; if (strcmp (argv[0], "address") == 0) - return (flag_sanitize & SANITIZE_ADDRESS) ? "" : NULL; + return (flag_sanitize & SANITIZE_USER_ADDRESS) ? "" : NULL; + if (strcmp (argv[0], "kernel-address") == 0) + return (flag_sanitize & SANITIZE_KERNEL_ADDRESS) ? "" : NULL; if (strcmp (argv[0], "thread") == 0) return (flag_sanitize & SANITIZE_THREAD) ? "" : NULL; if (strcmp (argv[0], "undefined") == 0) diff --git a/main/gcc/gcov-io.c b/main/gcc/gcov-io.c index c57077ee7ec..9ce05c87e84 100644 --- a/main/gcc/gcov-io.c +++ b/main/gcc/gcov-io.c @@ -39,7 +39,7 @@ static void gcov_allocate (unsigned); /* Optimum number of gcov_unsigned_t's read from or written to disk. */ #define GCOV_BLOCK_SIZE (1 << 10) -GCOV_LINKAGE struct gcov_var +GCOV_LINKAGE ATTRIBUTE_HIDDEN struct gcov_var { FILE *file; gcov_position_t start; /* Position of first byte of block */ diff --git a/main/gcc/gcov-tool.c b/main/gcc/gcov-tool.c index 074403305b8..ed8a9c41593 100644 --- a/main/gcc/gcov-tool.c +++ b/main/gcc/gcov-tool.c @@ -38,12 +38,11 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #include #include - extern int gcov_profile_merge (struct gcov_info*, struct gcov_info*, int, int); extern int gcov_profile_normalize (struct gcov_info*, gcov_type); extern int gcov_profile_scale (struct gcov_info*, float, int, int); extern struct gcov_info* gcov_read_profile_dir (const char*, int); -extern void gcov_exit (void); +extern void gcov_do_dump (struct gcov_info *, int); extern void gcov_set_verbose (void); extern void set_gcov_list (struct gcov_info *); @@ -110,8 +109,7 @@ gcov_output_files (const char *out, struct gcov_info *profile) if (ret) fatal_error ("Cannot change directory to %s", out); - set_gcov_list (profile); - gcov_exit (); + gcov_do_dump (profile, 0); ret = chdir (pwd); if (ret) diff --git a/main/gcc/gengtype.c b/main/gcc/gengtype.c index ffe3f94a6ae..e66941b9602 100644 --- a/main/gcc/gengtype.c +++ b/main/gcc/gengtype.c @@ -569,6 +569,40 @@ do_scalar_typedef (const char *s, struct fileloc *pos) do_typedef (s, &scalar_nonchar, pos); } +/* Similar to strtok_r. */ + +static char * +strtoken (char *str, const char *delim, char **next) +{ + char *p; + + if (str == NULL) + str = *next; + + /* Skip the leading delimiters. */ + str += strspn (str, delim); + if (*str == '\0') + /* This is an empty token. */ + return NULL; + + /* The current token. */ + p = str; + + /* Find the next delimiter. */ + str += strcspn (str, delim); + if (*str == '\0') + /* This is the last token. */ + *next = str; + else + { + /* Terminate the current token. */ + *str = '\0'; + /* Advance to the next token. */ + *next = str + 1; + } + + return p; +} /* Define TYPE_NAME to be a user defined type at location POS. */ @@ -599,7 +633,8 @@ create_user_defined_type (const char *type_name, struct fileloc *pos) comma-separated list of strings, implicitly assumed to be type names, potentially with "*" characters. */ char *arg = open_bracket + 1; - char *type_id = strtok (arg, ",>"); + char *next; + char *type_id = strtoken (arg, ",>", &next); pair_p fields = 0; while (type_id) { @@ -628,7 +663,7 @@ create_user_defined_type (const char *type_name, struct fileloc *pos) arg_type = resolve_typedef (field_name, pos); fields = create_field_at (fields, arg_type, field_name, 0, pos); - type_id = strtok (0, ",>"); + type_id = strtoken (0, ",>", &next); } /* Associate the field list to TY. */ diff --git a/main/gcc/gimple-fold.c b/main/gcc/gimple-fold.c index 4e8de8235f8..fa5681040ed 100644 --- a/main/gcc/gimple-fold.c +++ b/main/gcc/gimple-fold.c @@ -372,11 +372,11 @@ fold_gimple_assign (gimple_stmt_iterator *si) tree val = OBJ_TYPE_REF_EXPR (rhs); if (is_gimple_min_invariant (val)) return val; - else if (flag_devirtualize && virtual_method_call_p (val)) + else if (flag_devirtualize && virtual_method_call_p (rhs)) { bool final; vec targets - = possible_polymorphic_call_targets (val, stmt, &final); + = possible_polymorphic_call_targets (rhs, stmt, &final); if (final && targets.length () <= 1 && dbg_cnt (devirt)) { tree fndecl; @@ -395,7 +395,8 @@ fold_gimple_assign (gimple_stmt_iterator *si) ? targets[0]->name () : "__builtin_unreachable"); } - val = fold_convert (TREE_TYPE (val), fndecl); + val = fold_convert (TREE_TYPE (val), + build_fold_addr_expr_loc (loc, fndecl)); STRIP_USELESS_TYPE_CONVERSION (val); return val; } @@ -872,7 +873,7 @@ get_maxval_strlen (tree arg, tree *length, bitmap visited, int type) Note that some builtins expand into inline code that may not be valid in GIMPLE. Callers must take care. */ -tree +static tree gimple_fold_builtin (gimple stmt) { tree result, val[3]; @@ -2881,41 +2882,6 @@ get_base_constructor (tree base, HOST_WIDE_INT *bit_offset, } } -/* CTOR is STRING_CST. Fold reference of type TYPE and size SIZE - to the memory at bit OFFSET. - - We do only simple job of folding byte accesses. */ - -static tree -fold_string_cst_ctor_reference (tree type, tree ctor, - unsigned HOST_WIDE_INT offset, - unsigned HOST_WIDE_INT size) -{ - if (INTEGRAL_TYPE_P (type) - && (TYPE_MODE (type) - == TYPE_MODE (TREE_TYPE (TREE_TYPE (ctor)))) - && (GET_MODE_CLASS (TYPE_MODE (TREE_TYPE (TREE_TYPE (ctor)))) - == MODE_INT) - && GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (TREE_TYPE (ctor)))) == 1 - && size == BITS_PER_UNIT - && !(offset % BITS_PER_UNIT)) - { - offset /= BITS_PER_UNIT; - if (offset < (unsigned HOST_WIDE_INT) TREE_STRING_LENGTH (ctor)) - return build_int_cst_type (type, (TREE_STRING_POINTER (ctor) - [offset])); - /* Folding - const char a[20]="hello"; - return a[10]; - - might lead to offset greater than string length. In this case we - know value is either initialized to 0 or out of bounds. Return 0 - in both cases. */ - return build_zero_cst (type); - } - return NULL_TREE; -} - /* CTOR is CONSTRUCTOR of an array type. Fold reference of type TYPE and size SIZE to the memory at bit OFFSET. */ @@ -3107,8 +3073,19 @@ fold_ctor_reference (tree type, tree ctor, unsigned HOST_WIDE_INT offset, STRIP_NOPS (ret); return ret; } - if (TREE_CODE (ctor) == STRING_CST) - return fold_string_cst_ctor_reference (type, ctor, offset, size); + /* For constants and byte-aligned/sized reads try to go through + native_encode/interpret. */ + if (CONSTANT_CLASS_P (ctor) + && BITS_PER_UNIT == 8 + && offset % BITS_PER_UNIT == 0 + && size % BITS_PER_UNIT == 0 + && size <= MAX_BITSIZE_MODE_ANY_MODE) + { + unsigned char buf[MAX_BITSIZE_MODE_ANY_MODE / BITS_PER_UNIT]; + if (native_encode_expr (ctor, buf, size / BITS_PER_UNIT, + offset / BITS_PER_UNIT) > 0) + return native_interpret_expr (type, buf, size / BITS_PER_UNIT); + } if (TREE_CODE (ctor) == CONSTRUCTOR) { diff --git a/main/gcc/gimple-fold.h b/main/gcc/gimple-fold.h index 6b430668528..9b4e4566a12 100644 --- a/main/gcc/gimple-fold.h +++ b/main/gcc/gimple-fold.h @@ -25,7 +25,6 @@ along with GCC; see the file COPYING3. If not see extern tree canonicalize_constructor_val (tree, tree); extern tree get_symbol_constant_value (tree); extern void gimplify_and_update_call_from_tree (gimple_stmt_iterator *, tree); -extern tree gimple_fold_builtin (gimple); extern bool fold_stmt (gimple_stmt_iterator *); extern bool fold_stmt_inplace (gimple_stmt_iterator *); extern tree maybe_fold_and_comparisons (enum tree_code, tree, tree, diff --git a/main/gcc/gimple-iterator.h b/main/gcc/gimple-iterator.h index 909d58be892..47168b9d646 100644 --- a/main/gcc/gimple-iterator.h +++ b/main/gcc/gimple-iterator.h @@ -281,6 +281,30 @@ gsi_last_nondebug_bb (basic_block bb) return i; } +/* Iterates I statement iterator to the next non-virtual statement. */ + +static inline void +gsi_next_nonvirtual_phi (gimple_stmt_iterator *i) +{ + gimple phi; + + if (gsi_end_p (*i)) + return; + + phi = gsi_stmt (*i); + gcc_assert (phi != NULL); + + while (virtual_operand_p (gimple_phi_result (phi))) + { + gsi_next (i); + + if (gsi_end_p (*i)) + return; + + phi = gsi_stmt (*i); + } +} + /* Return the basic block associated with this iterator. */ static inline basic_block diff --git a/main/gcc/gimple-ssa-isolate-paths.c b/main/gcc/gimple-ssa-isolate-paths.c index 897b1804fa1..0b62915f55d 100644 --- a/main/gcc/gimple-ssa-isolate-paths.c +++ b/main/gcc/gimple-ssa-isolate-paths.c @@ -42,6 +42,8 @@ along with GCC; see the file COPYING3. If not see #include "cfgloop.h" #include "tree-pass.h" #include "tree-cfg.h" +#include "diagnostic-core.h" +#include "intl.h" static bool cfg_altered; @@ -132,13 +134,15 @@ insert_trap_and_remove_trailing_statements (gimple_stmt_iterator *si_p, tree op) Optimization is simple as well. Replace STMT in BB' with an unconditional trap and remove all outgoing edges from BB'. + If RET_ZERO, do not trap, only return NULL. + DUPLICATE is a pre-existing duplicate, use it as BB' if it exists. Return BB'. */ basic_block isolate_path (basic_block bb, basic_block duplicate, - edge e, gimple stmt, tree op) + edge e, gimple stmt, tree op, bool ret_zero) { gimple_stmt_iterator si, si2; edge_iterator ei; @@ -151,8 +155,9 @@ isolate_path (basic_block bb, basic_block duplicate, if (!duplicate) { duplicate = duplicate_block (bb, NULL, NULL); - for (ei = ei_start (duplicate->succs); (e2 = ei_safe_edge (ei)); ) - remove_edge (e2); + if (!ret_zero) + for (ei = ei_start (duplicate->succs); (e2 = ei_safe_edge (ei)); ) + remove_edge (e2); } /* Complete the isolation step by redirecting E to reach DUPLICATE. */ @@ -197,7 +202,17 @@ isolate_path (basic_block bb, basic_block duplicate, SI2 points to the duplicate of STMT in DUPLICATE. Insert a trap before SI2 and remove SI2 and all trailing statements. */ if (!gsi_end_p (si2)) - insert_trap_and_remove_trailing_statements (&si2, op); + { + if (ret_zero) + { + gimple ret = gsi_stmt (si2); + tree zero = build_zero_cst (TREE_TYPE (gimple_return_retval (ret))); + gimple_return_set_retval (ret, zero); + update_stmt (ret); + } + else + insert_trap_and_remove_trailing_statements (&si2, op); + } return duplicate; } @@ -255,16 +270,49 @@ find_implicit_erroneous_behaviour (void) i = next_i) { tree op = gimple_phi_arg_def (phi, i); + edge e = gimple_phi_arg_edge (phi, i); + imm_use_iterator iter; + gimple use_stmt; next_i = i + 1; + if (TREE_CODE (op) == ADDR_EXPR) + { + tree valbase = get_base_address (TREE_OPERAND (op, 0)); + if ((TREE_CODE (valbase) == VAR_DECL + && !is_global_var (valbase)) + || TREE_CODE (valbase) == PARM_DECL) + { + FOR_EACH_IMM_USE_STMT (use_stmt, iter, lhs) + { + if (gimple_code (use_stmt) != GIMPLE_RETURN + || gimple_return_retval (use_stmt) != lhs) + continue; + + if (warning_at (gimple_location (use_stmt), + OPT_Wreturn_local_addr, + "function may return address " + "of local variable")) + inform (DECL_SOURCE_LOCATION(valbase), + "declared here"); + + if (gimple_bb (use_stmt) == bb) + { + duplicate = isolate_path (bb, duplicate, e, + use_stmt, lhs, true); + + /* When we remove an incoming edge, we need to + reprocess the Ith element. */ + next_i = i; + cfg_altered = true; + } + } + } + } + if (!integer_zerop (op)) continue; - edge e = gimple_phi_arg_edge (phi, i); - imm_use_iterator iter; - gimple use_stmt; - /* We've got a NULL PHI argument. Now see if the PHI's result is dereferenced within BB. */ FOR_EACH_IMM_USE_STMT (use_stmt, iter, lhs) @@ -280,8 +328,8 @@ find_implicit_erroneous_behaviour (void) flag_isolate_erroneous_paths_attribute)) { - duplicate = isolate_path (bb, duplicate, - e, use_stmt, lhs); + duplicate = isolate_path (bb, duplicate, e, + use_stmt, lhs, false); /* When we remove an incoming edge, we need to reprocess the Ith element. */ @@ -347,9 +395,45 @@ find_explicit_erroneous_behaviour (void) cfg_altered = true; break; } + + /* Detect returning the address of a local variable. This only + becomes undefined behavior if the result is used, so we do not + insert a trap and only return NULL instead. */ + if (gimple_code (stmt) == GIMPLE_RETURN) + { + tree val = gimple_return_retval (stmt); + if (val && TREE_CODE (val) == ADDR_EXPR) + { + tree valbase = get_base_address (TREE_OPERAND (val, 0)); + if ((TREE_CODE (valbase) == VAR_DECL + && !is_global_var (valbase)) + || TREE_CODE (valbase) == PARM_DECL) + { + /* We only need it for this particular case. */ + calculate_dominance_info (CDI_POST_DOMINATORS); + const char* msg; + bool always_executed = dominated_by_p + (CDI_POST_DOMINATORS, + single_succ (ENTRY_BLOCK_PTR_FOR_FN (cfun)), bb); + if (always_executed) + msg = N_("function returns address of local variable"); + else + msg = N_("function may return address of " + "local variable"); + + if (warning_at (gimple_location (stmt), + OPT_Wreturn_local_addr, msg)) + inform (DECL_SOURCE_LOCATION(valbase), "declared here"); + tree zero = build_zero_cst (TREE_TYPE (val)); + gimple_return_set_retval (stmt, zero); + update_stmt (stmt); + } + } + } } } } + /* Search the function for statements which, if executed, would cause the program to fault such as a dereference of a NULL pointer. diff --git a/main/gcc/gimple-ssa-strength-reduction.c b/main/gcc/gimple-ssa-strength-reduction.c index d7c5db595e5..b13b7f73675 100644 --- a/main/gcc/gimple-ssa-strength-reduction.c +++ b/main/gcc/gimple-ssa-strength-reduction.c @@ -38,6 +38,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tree.h" #include "pointer-set.h" +#include "hash-map.h" #include "hash-table.h" #include "basic-block.h" #include "tree-ssa-alias.h" @@ -373,7 +374,7 @@ enum count_phis_status }; /* Pointer map embodying a mapping from statements to candidates. */ -static struct pointer_map_t *stmt_cand_map; +static hash_map *stmt_cand_map; /* Obstack for candidates. */ static struct obstack cand_obstack; @@ -435,7 +436,7 @@ static hash_table *base_cand_map; /* Pointer map used by tree_to_aff_combination_expand. */ static struct pointer_map_t *name_expansions; /* Pointer map embodying a mapping from bases to alternative bases. */ -static struct pointer_map_t *alt_base_map; +static hash_map *alt_base_map; /* Given BASE, use the tree affine combiniation facilities to find the underlying tree expression for BASE, with any @@ -447,7 +448,7 @@ static struct pointer_map_t *alt_base_map; static tree get_alternative_base (tree base) { - tree *result = (tree *) pointer_map_contains (alt_base_map, base); + tree *result = alt_base_map->get (base); if (result == NULL) { @@ -459,13 +460,9 @@ get_alternative_base (tree base) aff.offset = 0; expr = aff_combination_to_tree (&aff); - result = (tree *) pointer_map_insert (alt_base_map, base); - gcc_assert (!*result); + gcc_assert (!alt_base_map->put (base, base == expr ? NULL : expr)); - if (expr == base) - *result = NULL; - else - *result = expr; + return expr == base ? NULL : expr; } return *result; @@ -724,7 +721,7 @@ base_cand_from_table (tree base_in) if (!def) return (slsr_cand_t) NULL; - result = (slsr_cand_t *) pointer_map_contains (stmt_cand_map, def); + result = stmt_cand_map->get (def); if (result && (*result)->kind != CAND_REF) return *result; @@ -737,9 +734,7 @@ base_cand_from_table (tree base_in) static void add_cand_for_stmt (gimple gs, slsr_cand_t c) { - void **slot = pointer_map_insert (stmt_cand_map, gs); - gcc_assert (!*slot); - *slot = c; + gcc_assert (!stmt_cand_map->put (gs, c)); } /* Given PHI which contains a phi statement, determine whether it @@ -3628,7 +3623,7 @@ pass_strength_reduction::execute (function *fun) cand_vec.create (128); /* Allocate the mapping from statements to candidate indices. */ - stmt_cand_map = pointer_map_create (); + stmt_cand_map = new hash_map; /* Create the obstack where candidate chains will reside. */ gcc_obstack_init (&chain_obstack); @@ -3637,7 +3632,7 @@ pass_strength_reduction::execute (function *fun) base_cand_map = new hash_table (500); /* Allocate the mapping from bases to alternative bases. */ - alt_base_map = pointer_map_create (); + alt_base_map = new hash_map; /* Initialize the loop optimizer. We need to detect flow across back edges, and this gives us dominator information as well. */ @@ -3654,7 +3649,7 @@ pass_strength_reduction::execute (function *fun) dump_cand_chains (); } - pointer_map_destroy (alt_base_map); + delete alt_base_map; free_affine_expand_cache (&name_expansions); /* Analyze costs and make appropriate replacements. */ @@ -3664,7 +3659,7 @@ pass_strength_reduction::execute (function *fun) delete base_cand_map; base_cand_map = NULL; obstack_free (&chain_obstack, NULL); - pointer_map_destroy (stmt_cand_map); + delete stmt_cand_map; cand_vec.release (); obstack_free (&cand_obstack, NULL); diff --git a/main/gcc/gimple-walk.c b/main/gcc/gimple-walk.c index b6f0495beec..f4f67572c81 100644 --- a/main/gcc/gimple-walk.c +++ b/main/gcc/gimple-walk.c @@ -180,7 +180,7 @@ tree walk_gimple_op (gimple stmt, walk_tree_fn callback_op, struct walk_stmt_info *wi) { - struct pointer_set_t *pset = (wi) ? wi->pset : NULL; + hash_set *pset = (wi) ? wi->pset : NULL; unsigned i; tree ret = NULL_TREE; diff --git a/main/gcc/gimple-walk.h b/main/gcc/gimple-walk.h index 555eb181a08..5b75fdc3f41 100644 --- a/main/gcc/gimple-walk.h +++ b/main/gcc/gimple-walk.h @@ -36,7 +36,7 @@ struct walk_stmt_info /* Pointer map used to mark visited tree nodes when calling walk_tree on each operand. If set to NULL, duplicate tree nodes will be visited more than once. */ - struct pointer_set_t *pset; + hash_set *pset; /* Operand returned by the callbacks. This is set when calling walk_gimple_seq. If the walk_stmt_fn or walk_tree_fn callback diff --git a/main/gcc/gimplify.c b/main/gcc/gimplify.c index 5d560802548..8b957176506 100644 --- a/main/gcc/gimplify.c +++ b/main/gcc/gimplify.c @@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. If not see #include "coretypes.h" #include "tree.h" #include "expr.h" +#include "hash-set.h" #include "pointer-set.h" #include "hash-table.h" #include "basic-block.h" @@ -134,7 +135,7 @@ struct gimplify_omp_ctx { struct gimplify_omp_ctx *outer_context; splay_tree variables; - struct pointer_set_t *privatized_types; + hash_set *privatized_types; location_t location; enum omp_clause_default_kind default_kind; enum omp_region_type region_type; @@ -352,7 +353,7 @@ new_omp_context (enum omp_region_type region_type) c = XCNEW (struct gimplify_omp_ctx); c->outer_context = gimplify_omp_ctxp; c->variables = splay_tree_new (splay_tree_compare_decl_uid, 0, 0); - c->privatized_types = pointer_set_create (); + c->privatized_types = new hash_set; c->location = input_location; c->region_type = region_type; if ((region_type & ORT_TASK) == 0) @@ -369,7 +370,7 @@ static void delete_omp_context (struct gimplify_omp_ctx *c) { splay_tree_delete (c->variables); - pointer_set_destroy (c->privatized_types); + delete c->privatized_types; XDELETE (c); } @@ -744,7 +745,7 @@ mostly_copy_tree_r (tree *tp, int *walk_subtrees, void *data) copy their subtrees if we can make sure to do it only once. */ if (code == SAVE_EXPR || code == TARGET_EXPR || code == BIND_EXPR) { - if (data && !pointer_set_insert ((struct pointer_set_t *)data, t)) + if (data && !((hash_set *)data)->add (t)) ; else *walk_subtrees = 0; @@ -829,15 +830,14 @@ unshare_body (tree fndecl) struct cgraph_node *cgn = cgraph_node::get (fndecl); /* If the language requires deep unsharing, we need a pointer set to make sure we don't repeatedly unshare subtrees of unshareable nodes. */ - struct pointer_set_t *visited - = lang_hooks.deep_unsharing ? pointer_set_create () : NULL; + hash_set *visited + = lang_hooks.deep_unsharing ? new hash_set : NULL; copy_if_shared (&DECL_SAVED_TREE (fndecl), visited); copy_if_shared (&DECL_SIZE (DECL_RESULT (fndecl)), visited); copy_if_shared (&DECL_SIZE_UNIT (DECL_RESULT (fndecl)), visited); - if (visited) - pointer_set_destroy (visited); + delete visited; if (cgn) for (cgn = cgn->nested; cgn; cgn = cgn->next_nested) @@ -1733,7 +1733,7 @@ gimplify_conversion (tree *expr_p) } /* Nonlocal VLAs seen in the current function. */ -static struct pointer_set_t *nonlocal_vlas; +static hash_set *nonlocal_vlas; /* The VAR_DECLs created for nonlocal VLAs for debug info purposes. */ static tree nonlocal_vla_vars; @@ -1784,7 +1784,7 @@ gimplify_var_or_parm_decl (tree *expr_p) && (ctx->region_type == ORT_WORKSHARE || ctx->region_type == ORT_SIMD)) ctx = ctx->outer_context; - if (!ctx && !pointer_set_insert (nonlocal_vlas, decl)) + if (!ctx && !nonlocal_vlas->add (decl)) { tree copy = copy_node (decl); @@ -5473,7 +5473,7 @@ omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *ctx, tree type) return; type = TYPE_MAIN_VARIANT (type); - if (pointer_set_insert (ctx->privatized_types, type)) + if (ctx->privatized_types->add (type)) return; switch (TREE_CODE (type)) @@ -8776,7 +8776,7 @@ gimplify_body (tree fndecl, bool do_parms) cgn = cgraph_node::get (fndecl); if (cgn && cgn->origin) - nonlocal_vlas = pointer_set_create (); + nonlocal_vlas = new hash_set; /* Make sure input_location isn't set to something weird. */ input_location = DECL_SOURCE_LOCATION (fndecl); @@ -8840,7 +8840,7 @@ gimplify_body (tree fndecl, bool do_parms) nonlocal_vla_vars); nonlocal_vla_vars = NULL_TREE; } - pointer_set_destroy (nonlocal_vlas); + delete nonlocal_vlas; nonlocal_vlas = NULL; } diff --git a/main/gcc/go/ChangeLog b/main/gcc/go/ChangeLog index 6b535851d6d..069618d2ca8 100644 --- a/main/gcc/go/ChangeLog +++ b/main/gcc/go/ChangeLog @@ -1,3 +1,8 @@ +2014-07-24 Uros Bizjak + + * go-gcc.cc (Gcc_backend::global_variable_set_init): Rename + symtab_get_node to symtab_node::get. + 2014-06-13 Ian Lance Taylor PR go/61496 @@ -7,7 +12,7 @@ 2014-06-10 Jan Hubicka - * go/go-gcc.cc (Gcc_backend::global_variable_set_init): Use + * go-gcc.cc (Gcc_backend::global_variable_set_init): Use symtab_get_node(var_decl)->implicit_section. 2014-06-07 Jan Hubicka diff --git a/main/gcc/go/go-gcc.cc b/main/gcc/go/go-gcc.cc index 0c9cb70a655..97904d06d43 100644 --- a/main/gcc/go/go-gcc.cc +++ b/main/gcc/go/go-gcc.cc @@ -2374,8 +2374,8 @@ Gcc_backend::global_variable_set_init(Bvariable* var, Bexpression* expr) // If this variable goes in a unique section, it may need to go into // a different one now that DECL_INITIAL is set. - if (symtab_get_node(var_decl) - && symtab_get_node(var_decl)->implicit_section) + if (symtab_node::get(var_decl) + && symtab_node::get(var_decl)->implicit_section) { set_decl_section_name (var_decl, NULL); resolve_unique_section (var_decl, diff --git a/main/gcc/godump.c b/main/gcc/godump.c index 2afd7f171a0..7566f4d3eff 100644 --- a/main/gcc/godump.c +++ b/main/gcc/godump.c @@ -33,7 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "diagnostic-core.h" #include "tree.h" #include "ggc.h" -#include "pointer-set.h" +#include "hash-set.h" #include "obstack.h" #include "debug.h" #include "wide-int-print.h" @@ -525,11 +525,11 @@ go_type_decl (tree decl, int local) struct godump_container { /* DECLs that we have already seen. */ - struct pointer_set_t *decls_seen; + hash_set decls_seen; /* Types which may potentially have to be defined as dummy types. */ - struct pointer_set_t *pot_dummy_types; + hash_set pot_dummy_types; /* Go keywords. */ htab_t keyword_hash; @@ -569,8 +569,8 @@ go_format_type (struct godump_container *container, tree type, ob = &container->type_obstack; if (TYPE_NAME (type) != NULL_TREE - && (pointer_set_contains (container->decls_seen, type) - || pointer_set_contains (container->decls_seen, TYPE_NAME (type))) + && (container->decls_seen.contains (type) + || container->decls_seen.contains (TYPE_NAME (type))) && (AGGREGATE_TYPE_P (type) || POINTER_TYPE_P (type) || TREE_CODE (type) == FUNCTION_TYPE)) @@ -590,7 +590,7 @@ go_format_type (struct godump_container *container, tree type, return ret; } - pointer_set_insert (container->decls_seen, type); + container->decls_seen.add (type); switch (TREE_CODE (type)) { @@ -697,8 +697,7 @@ go_format_type (struct godump_container *container, tree type, definition. So this struct or union is a potential dummy type. */ if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (type))) - pointer_set_insert (container->pot_dummy_types, - IDENTIFIER_POINTER (name)); + container->pot_dummy_types.add (IDENTIFIER_POINTER (name)); return ret; } @@ -948,10 +947,10 @@ go_output_typedef (struct godump_container *container, tree decl) separately. */ if (TREE_CODE (TREE_TYPE (decl)) == ENUMERAL_TYPE && TYPE_SIZE (TREE_TYPE (decl)) != 0 - && !pointer_set_contains (container->decls_seen, TREE_TYPE (decl)) + && !container->decls_seen.contains (TREE_TYPE (decl)) && (TYPE_CANONICAL (TREE_TYPE (decl)) == NULL_TREE - || !pointer_set_contains (container->decls_seen, - TYPE_CANONICAL (TREE_TYPE (decl))))) + || !container->decls_seen.contains + (TYPE_CANONICAL (TREE_TYPE (decl))))) { tree element; @@ -988,10 +987,9 @@ go_output_typedef (struct godump_container *container, tree decl) mhval->value = xstrdup (buf); *slot = mhval; } - pointer_set_insert (container->decls_seen, TREE_TYPE (decl)); + container->decls_seen.add (TREE_TYPE (decl)); if (TYPE_CANONICAL (TREE_TYPE (decl)) != NULL_TREE) - pointer_set_insert (container->decls_seen, - TYPE_CANONICAL (TREE_TYPE (decl))); + container->decls_seen.add (TYPE_CANONICAL (TREE_TYPE (decl))); } if (DECL_NAME (decl) != NULL_TREE) @@ -1027,7 +1025,7 @@ go_output_typedef (struct godump_container *container, tree decl) size); } - pointer_set_insert (container->decls_seen, decl); + container->decls_seen.add (decl); } else if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (decl))) { @@ -1072,11 +1070,11 @@ go_output_var (struct godump_container *container, tree decl) { bool is_valid; - if (pointer_set_contains (container->decls_seen, decl) - || pointer_set_contains (container->decls_seen, DECL_NAME (decl))) + if (container->decls_seen.contains (decl) + || container->decls_seen.contains (DECL_NAME (decl))) return; - pointer_set_insert (container->decls_seen, decl); - pointer_set_insert (container->decls_seen, DECL_NAME (decl)); + container->decls_seen.add (decl); + container->decls_seen.add (DECL_NAME (decl)); is_valid = go_format_type (container, TREE_TYPE (decl), true, false); if (is_valid @@ -1103,11 +1101,10 @@ go_output_var (struct godump_container *container, tree decl) { tree type_name = TYPE_NAME (TREE_TYPE (decl)); if (TREE_CODE (type_name) == IDENTIFIER_NODE) - pointer_set_insert (container->pot_dummy_types, - IDENTIFIER_POINTER (type_name)); + container->pot_dummy_types.add (IDENTIFIER_POINTER (type_name)); else if (TREE_CODE (type_name) == TYPE_DECL) - pointer_set_insert (container->pot_dummy_types, - IDENTIFIER_POINTER (DECL_NAME (type_name))); + container->pot_dummy_types.add + (IDENTIFIER_POINTER (DECL_NAME (type_name))); } } @@ -1147,10 +1144,10 @@ keyword_hash_init (struct godump_container *container) /* Traversing the pot_dummy_types and seeing which types are present in the global types hash table and creating dummy definitions if - not found. This function is invoked by pointer_set_traverse. */ + not found. This function is invoked by hash_set::traverse. */ -static bool -find_dummy_types (const void *ptr, void *adata) +bool +find_dummy_types (const char *const &ptr, godump_container *adata) { struct godump_container *data = (struct godump_container *) adata; const char *type = (const char *) ptr; @@ -1175,8 +1172,6 @@ go_finish (const char *filename) real_debug_hooks->finish (filename); - container.decls_seen = pointer_set_create (); - container.pot_dummy_types = pointer_set_create (); container.type_hash = htab_create (100, htab_hash_string, string_hash_eq, NULL); container.invalid_hash = htab_create (10, htab_hash_string, @@ -1211,11 +1206,9 @@ go_finish (const char *filename) htab_traverse_noresize (macro_hash, go_print_macro, NULL); /* To emit dummy definitions. */ - pointer_set_traverse (container.pot_dummy_types, find_dummy_types, - (void *) &container); + container.pot_dummy_types.traverse + (&container); - pointer_set_destroy (container.decls_seen); - pointer_set_destroy (container.pot_dummy_types); htab_delete (container.type_hash); htab_delete (container.invalid_hash); htab_delete (container.keyword_hash); diff --git a/main/gcc/graphite-isl-ast-to-gimple.c b/main/gcc/graphite-isl-ast-to-gimple.c index 77b5ed4afe1..fd04118140d 100644 --- a/main/gcc/graphite-isl-ast-to-gimple.c +++ b/main/gcc/graphite-isl-ast-to-gimple.c @@ -122,10 +122,16 @@ gcc_expression_from_isl_expression (tree type, __isl_take isl_ast_expr *, ivs_params &ip); /* Return the tree variable that corresponds to the given isl ast identifier - expression (an isl_ast_expr of type isl_ast_expr_id). */ + expression (an isl_ast_expr of type isl_ast_expr_id). + + FIXME: We should replace blind conversation of id's type with derivation + of the optimal type when we get the corresponding isl support. Blindly + converting type sizes may be problematic when we switch to smaller + types. */ static tree -gcc_expression_from_isl_ast_expr_id (__isl_keep isl_ast_expr *expr_id, +gcc_expression_from_isl_ast_expr_id (tree type, + __isl_keep isl_ast_expr *expr_id, ivs_params &ip) { gcc_assert (isl_ast_expr_get_type (expr_id) == isl_ast_expr_id); @@ -136,7 +142,7 @@ gcc_expression_from_isl_ast_expr_id (__isl_keep isl_ast_expr *expr_id, gcc_assert (res != ip.end () && "Could not map isl_id to tree expression"); isl_ast_expr_free (expr_id); - return res->second; + return fold_convert (type, res->second); } /* Converts an isl_ast_expr_int expression E to a GCC expression tree of @@ -351,7 +357,7 @@ gcc_expression_from_isl_expression (tree type, __isl_take isl_ast_expr *expr, switch (isl_ast_expr_get_type (expr)) { case isl_ast_expr_id: - return gcc_expression_from_isl_ast_expr_id (expr, ip); + return gcc_expression_from_isl_ast_expr_id (type, expr, ip); case isl_ast_expr_int: return gcc_expression_from_isl_expr_int (type, expr); @@ -645,6 +651,43 @@ translate_isl_ast_node_block (loop_p context_loop, isl_ast_node_list_free (node_list); return next_e; } + +/* Creates a new if region corresponding to ISL's cond. */ + +static edge +graphite_create_new_guard (edge entry_edge, __isl_take isl_ast_expr *if_cond, + ivs_params &ip) +{ + tree type = + build_nonstandard_integer_type (graphite_expression_type_precision, 0); + tree cond_expr = gcc_expression_from_isl_expression (type, if_cond, ip); + edge exit_edge = create_empty_if_region_on_edge (entry_edge, cond_expr); + return exit_edge; +} + +/* Translates an isl_ast_node_if to Gimple. */ + +static edge +translate_isl_ast_node_if (loop_p context_loop, + __isl_keep isl_ast_node *node, + edge next_e, ivs_params &ip) +{ + gcc_assert (isl_ast_node_get_type (node) == isl_ast_node_if); + isl_ast_expr *if_cond = isl_ast_node_if_get_cond (node); + edge last_e = graphite_create_new_guard (next_e, if_cond, ip); + + edge true_e = get_true_edge_from_guard_bb (next_e->dest); + isl_ast_node *then_node = isl_ast_node_if_get_then (node); + translate_isl_ast (context_loop, then_node, true_e, ip); + isl_ast_node_free (then_node); + + edge false_e = get_false_edge_from_guard_bb (next_e->dest); + isl_ast_node *else_node = isl_ast_node_if_get_else (node); + if (isl_ast_node_get_type (else_node) != isl_ast_node_error) + translate_isl_ast (context_loop, else_node, false_e, ip); + isl_ast_node_free (else_node); + return last_e; +} /* Translates an ISL AST node NODE to GCC representation in the context of a SESE. */ @@ -663,7 +706,8 @@ translate_isl_ast (loop_p context_loop, __isl_keep isl_ast_node *node, next_e, ip); case isl_ast_node_if: - return next_e; + return translate_isl_ast_node_if (context_loop, node, + next_e, ip); case isl_ast_node_user: return translate_isl_ast_node_user (node, next_e, ip); diff --git a/main/gcc/graphite-sese-to-poly.c b/main/gcc/graphite-sese-to-poly.c index 0bc443302c6..3254df97463 100644 --- a/main/gcc/graphite-sese-to-poly.c +++ b/main/gcc/graphite-sese-to-poly.c @@ -2044,6 +2044,8 @@ new_pbb_from_pbb (scop_p scop, poly_bb_p pbb, basic_block bb) break; pbb1->domain = isl_set_copy (pbb->domain); + pbb1->domain = isl_set_set_tuple_id (pbb1->domain, + isl_id_for_pbb (scop, pbb1)); GBB_PBB (gbb1) = pbb1; GBB_CONDITIONS (gbb1) = GBB_CONDITIONS (gbb).copy (); diff --git a/main/gcc/hash-map.h b/main/gcc/hash-map.h index 0b50f724251..ec48844b81f 100644 --- a/main/gcc/hash-map.h +++ b/main/gcc/hash-map.h @@ -93,7 +93,7 @@ private: static void mark_key_deleted (T *&k) { - k = static_cast (1); + k = reinterpret_cast (1); } template @@ -185,6 +185,11 @@ public: return e->m_value; } + void remove (const Key &k) + { + m_table.remove_elt_with_hash (k, Traits::hash (k)); + } + /* Call the call back on each pair of key and value with the passed in arg. */ @@ -196,6 +201,15 @@ public: f ((*iter).m_key, (*iter).m_value, a); } + template + void traverse (Arg a) const + { + for (typename hash_table::iterator iter = m_table.begin (); + iter != m_table.end (); ++iter) + if (!f ((*iter).m_key, &(*iter).m_value, a)) + break; + } + private: hash_table m_table; }; diff --git a/main/gcc/hash-map.h b/main/gcc/hash-set.h similarity index 50% copy from main/gcc/hash-map.h copy to main/gcc/hash-set.h index 0b50f724251..47bae9ed77d 100644 --- a/main/gcc/hash-map.h +++ b/main/gcc/hash-set.h @@ -1,4 +1,4 @@ -/* A type-safe hash map. +/* A type-safe hash set. Copyright (C) 2014 Free Software Foundation, Inc. This file is part of GCC. @@ -18,14 +18,14 @@ along with GCC; see the file COPYING3. If not see . */ -#ifndef hash_map_h -#define hash_map_h +#ifndef hash_set_h +#define hash_set_h #include "hash-table.h" /* implement default behavior for traits when types allow it. */ -struct default_hashmap_traits +struct default_hashset_traits { /* Hashes the passed in key. */ @@ -36,24 +36,18 @@ struct default_hashmap_traits return uintptr_t(p) >> 3; } - /* The right thing to do here would be using is_integral to only allow - template arguments of integer type, but reimplementing that is a pain, so - we'll just promote everything to [u]int64_t and truncate to hashval_t. */ - - static hashval_t hash (uint64_t v) { return v; } - static hashval_t hash (int64_t v) { return v; } + template static hashval_t hash(const T &v) { return v; } /* Return true if the two keys passed as arguments are equal. */ template static bool - equal_keys (const T &a, const T &b) + equal (const T &a, const T &b) { return a == b; } - /* Called to dispose of the key and value before marking the entry as - deleted. */ + /* Called to dispose of the key before marking the entry as deleted. */ template static void remove (T &v) { v.~T (); } @@ -61,57 +55,40 @@ struct default_hashmap_traits template static void - mark_deleted (T &e) + mark_deleted (T *&e) { - mark_key_deleted (e.m_key); + e = reinterpret_cast (1); } /* Mark the passed in entry as being empty. */ template static void - mark_empty (T &e) + mark_empty (T *&e) { - mark_key_empty (e.m_key); + e = NULL; } /* Return true if the passed in entry is marked as deleted. */ template static bool - is_deleted (T &e) + is_deleted (T *e) { - return e.m_key == (void *)1; + return e == reinterpret_cast (1); } /* Return true if the passed in entry is marked as empty. */ - template static bool is_empty (T &e) { return e.m_key == NULL; } - -private: - template - static void - mark_key_deleted (T *&k) - { - k = static_cast (1); - } - - template - static void - mark_key_empty (T *&k) - { - k = static_cast (0); - } + template static bool is_empty (T *e) { return e == NULL; } }; -template -class hash_map +template +class hash_set { struct hash_entry { Key m_key; - Value m_value; typedef hash_entry value_type; typedef Key compare_type; @@ -124,30 +101,42 @@ class hash_map static bool equal (const hash_entry &a, const Key &b) { - return Traits::equal_keys (a.m_key, b); + return Traits::equal (a.m_key, b); } - static void remove (hash_entry &e) { Traits::remove (e); } + static void remove (hash_entry &e) { Traits::remove (e.m_key); } - static void mark_deleted (hash_entry &e) { Traits::mark_deleted (e); } + static void + mark_deleted (hash_entry &e) + { + Traits::mark_deleted (e.m_key); + } static bool is_deleted (const hash_entry &e) { - return Traits::is_deleted (e); + return Traits::is_deleted (e.m_key); } - static void mark_empty (hash_entry &e) { Traits::mark_empty (e); } - static bool is_empty (const hash_entry &e) { return Traits::is_empty (e); } + static void + mark_empty (hash_entry &e) + { + Traits::mark_empty (e.m_key); + } + + static bool + is_empty (const hash_entry &e) + { + return Traits::is_empty (e.m_key); + } }; public: - explicit hash_map (size_t n = 13) : m_table (n) {} + explicit hash_set (size_t n = 13) : m_table (n) {} - /* If key k isn't already in the map add key k with value v to the map, and - return false. Otherwise set the value of the entry for key k to be v and - return true. */ + /* If key k isn't already in the map add it to the map, and + return false. Otherwise return true. */ - bool put (const Key &k, const Value &v) + bool add (const Key &k) { hash_entry *e = m_table.find_slot_with_hash (k, Traits::hash (k), INSERT); @@ -155,45 +144,26 @@ public: if (!existed) e->m_key = k; - e->m_value = v; return existed; } /* if the passed in key is in the map return its value otherwise NULL. */ - Value *get (const Key &k) + bool contains (const Key &k) { hash_entry &e = m_table.find_with_hash (k, Traits::hash (k)); - return Traits::is_empty (e) ? NULL : &e.m_value; - } - - /* Return a reference to the value for the passed in key, creating the entry - if it doesn't already exist. If existed is not NULL then it is set to false - if the key was not previously in the map, and true otherwise. */ - - Value &get_or_insert (const Key &k, bool *existed = NULL) - { - hash_entry *e = m_table.find_slot_with_hash (k, Traits::hash (k), - INSERT); - bool ins = Traits::is_empty (*e); - if (ins) - e->m_key = k; - - if (existed != NULL) - *existed = !ins; - - return e->m_value; + return !Traits::is_empty (e.m_key); } /* Call the call back on each pair of key and value with the passed in arg. */ - template + template void traverse (Arg a) const { for (typename hash_table::iterator iter = m_table.begin (); iter != m_table.end (); ++iter) - f ((*iter).m_key, (*iter).m_value, a); + f ((*iter).m_key, a); } private: diff --git a/main/gcc/inchash.c b/main/gcc/inchash.c new file mode 100644 index 00000000000..0f8583eab5f --- /dev/null +++ b/main/gcc/inchash.c @@ -0,0 +1,75 @@ +/* Incremential hashing for jhash. + Copyright (C) 2014 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "hashtab.h" +#include "inchash.h" + +/* Borrowed from hashtab.c iterative_hash implementation. */ +#define mix(a,b,c) \ +{ \ + a -= b; a -= c; a ^= (c>>13); \ + b -= c; b -= a; b ^= (a<< 8); \ + c -= a; c -= b; c ^= ((b&0xffffffff)>>13); \ + a -= b; a -= c; a ^= ((c&0xffffffff)>>12); \ + b -= c; b -= a; b = (b ^ (a<<16)) & 0xffffffff; \ + c -= a; c -= b; c = (c ^ (b>> 5)) & 0xffffffff; \ + a -= b; a -= c; a = (a ^ (c>> 3)) & 0xffffffff; \ + b -= c; b -= a; b = (b ^ (a<<10)) & 0xffffffff; \ + c -= a; c -= b; c = (c ^ (b>>15)) & 0xffffffff; \ +} + + +/* Produce good hash value combining VAL and VAL2. */ +hashval_t +iterative_hash_hashval_t (hashval_t val, hashval_t val2) +{ + /* the golden ratio; an arbitrary value. */ + hashval_t a = 0x9e3779b9; + + mix (a, val, val2); + return val2; +} + +/* Produce good hash value combining VAL and VAL2. */ + +hashval_t +iterative_hash_host_wide_int (HOST_WIDE_INT val, hashval_t val2) +{ + if (sizeof (HOST_WIDE_INT) == sizeof (hashval_t)) + return iterative_hash_hashval_t (val, val2); + else + { + hashval_t a = (hashval_t) val; + /* Avoid warnings about shifting of more than the width of the type on + hosts that won't execute this path. */ + int zero = 0; + hashval_t b = (hashval_t) (val >> (sizeof (hashval_t) * 8 + zero)); + mix (a, b, val2); + if (sizeof (HOST_WIDE_INT) > 2 * sizeof (hashval_t)) + { + hashval_t a = (hashval_t) (val >> (sizeof (hashval_t) * 16 + zero)); + hashval_t b = (hashval_t) (val >> (sizeof (hashval_t) * 24 + zero)); + mix (a, b, val2); + } + return val2; + } +} diff --git a/main/gcc/inchash.h b/main/gcc/inchash.h new file mode 100644 index 00000000000..c157e302509 --- /dev/null +++ b/main/gcc/inchash.h @@ -0,0 +1,137 @@ +/* An incremental hash abstract data type. + Copyright (C) 2014 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#ifndef INCHASH_H +#define INCHASH_H 1 + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "hashtab.h" + +/* This file implements an incremential hash function ADT, to be used + by code that incrementially hashes a lot of unrelated data + (not in a single memory block) into a single value. The goal + is to make it easy to plug in efficient hash algorithms. + Currently it just implements the plain old jhash based + incremental hash from gcc's tree.c. */ + +extern hashval_t iterative_hash_host_wide_int (HOST_WIDE_INT, hashval_t); +extern hashval_t iterative_hash_hashval_t (hashval_t, hashval_t); + +namespace inchash +{ + +class hash +{ + public: + + /* Start incremential hashing, optionally with SEED. */ + hash (hashval_t seed = 0) + { + val = seed; + bits = 0; + } + + /* End incremential hashing and provide the final value. */ + hashval_t end () + { + return val; + } + + /* Add unsigned value V. */ + void add_int (unsigned v) + { + val = iterative_hash_hashval_t (v, val); + } + + /* Add HOST_WIDE_INT value V. */ + void add_wide_int (HOST_WIDE_INT v) + { + val = iterative_hash_host_wide_int (v, val); + } + + /* Hash in pointer PTR. */ + void add_ptr (void *ptr) + { + add (&ptr, sizeof (ptr)); + } + + /* Add a memory block DATA with size LEN. */ + void add (const void *data, size_t len) + { + val = iterative_hash (data, len, val); + } + + /* Merge hash value OTHER. */ + void merge_hash (hashval_t other) + { + val = iterative_hash_hashval_t (other, val); + } + + /* Hash in state from other inchash OTHER. */ + void merge (hash &other) + { + merge_hash (other.val); + } + + template void add_object(T &obj) + { + add (&obj, sizeof(T)); + } + + /* Support for accumulating boolean flags */ + + void add_flag (bool flag) + { + bits = (bits << 1) | flag; + } + + void commit_flag () + { + add_int (bits); + bits = 0; + } + + /* Support for commutative hashing. Add A and B in a defined order + based on their value. This is useful for hashing commutative + expressions, so that A+B and B+A get the same hash. */ + + void add_commutative (hash &a, hash &b) + { + if (a.end() > b.end()) + { + merge (b); + merge (a); + } + else + { + merge (a); + merge (b); + } + } + + private: + hashval_t val; + unsigned bits; +}; + +} + +#endif diff --git a/main/gcc/ipa-devirt.c b/main/gcc/ipa-devirt.c index 7c4151a1857..56eeaf5c9c2 100644 --- a/main/gcc/ipa-devirt.c +++ b/main/gcc/ipa-devirt.c @@ -115,9 +115,10 @@ along with GCC; see the file COPYING3. If not see #include "cgraph.h" #include "expr.h" #include "tree-pass.h" -#include "pointer-set.h" +#include "hash-set.h" #include "target.h" #include "hash-table.h" +#include "inchash.h" #include "tree-pretty-print.h" #include "ipa-utils.h" #include "tree-ssa-alias.h" @@ -132,18 +133,20 @@ along with GCC; see the file COPYING3. If not see #include "dbgcnt.h" #include "stor-layout.h" #include "intl.h" +#include "hash-map.h" -static bool odr_types_equivalent_p (tree, tree, bool, bool *, pointer_set_t *); +static bool odr_types_equivalent_p (tree, tree, bool, bool *, + hash_set *); static bool odr_violation_reported = false; /* Dummy polymorphic call context. */ const ipa_polymorphic_call_context ipa_dummy_polymorphic_call_context - = {0, NULL, false, true}; + = {0, 0, NULL, NULL, false, true, true}; /* Pointer set of all call targets appearing in the cache. */ -static pointer_set_t *cached_polymorphic_call_targets; +static hash_set *cached_polymorphic_call_targets; /* The node of type inheritance graph. For each type unique in One Defintion Rule (ODR) sense, we produce one node linking all @@ -162,7 +165,7 @@ struct GTY(()) odr_type_d /* All equivalent types, if more than one. */ vec *types; /* Set of all equivalent types, if NON-NULL. */ - pointer_set_t * GTY((skip)) types_set; + hash_set * GTY((skip)) types_set; /* Unique ID indexing the type in odr_types array. */ int id; @@ -174,6 +177,8 @@ struct GTY(()) odr_type_d bool odr_violated; }; +static bool contains_type_p (tree, HOST_WIDE_INT, tree); + /* Return true if BINFO corresponds to a type with virtual methods. @@ -408,7 +413,7 @@ odr_hasher::remove (value_type *v) v->bases.release (); v->derived_types.release (); if (v->types_set) - pointer_set_destroy (v->types_set); + delete v->types_set; ggc_free (v); } @@ -438,7 +443,7 @@ set_type_binfo (tree type, tree binfo) /* Compare T2 and T2 based on name or structure. */ static bool -odr_subtypes_equivalent_p (tree t1, tree t2, pointer_set_t *visited) +odr_subtypes_equivalent_p (tree t1, tree t2, hash_set *visited) { bool an1, an2; @@ -472,7 +477,7 @@ odr_subtypes_equivalent_p (tree t1, tree t2, pointer_set_t *visited) /* This should really be a pair hash, but for the moment we do not need 100% reliability and it would be better to compare all ODR types so recursion here is needed only for component types. */ - if (pointer_set_insert (visited, t1)) + if (visited->add (t1)) return true; return odr_types_equivalent_p (t1, t2, false, NULL, visited); } @@ -561,7 +566,7 @@ warn_types_mismatch (tree t1, tree t2) gimple_canonical_types_compatible_p. */ static bool -odr_types_equivalent_p (tree t1, tree t2, bool warn, bool *warned, pointer_set_t *visited) +odr_types_equivalent_p (tree t1, tree t2, bool warn, bool *warned, hash_set *visited) { /* Check first for the obvious case of pointer identity. */ if (t1 == t2) @@ -937,7 +942,7 @@ add_type_duplicate (odr_type val, tree type) { bool build_bases = false; if (!val->types_set) - val->types_set = pointer_set_create (); + val->types_set = new hash_set; /* Always prefer complete type to be the leader. */ if (!COMPLETE_TYPE_P (val->type) @@ -951,20 +956,20 @@ add_type_duplicate (odr_type val, tree type) } /* See if this duplicate is new. */ - if (!pointer_set_insert (val->types_set, type)) + if (!val->types_set->add (type)) { bool merge = true; bool base_mismatch = false; unsigned int i,j; bool warned = false; - pointer_set_t *visited = pointer_set_create (); + hash_set visited; gcc_assert (in_lto_p); vec_safe_push (val->types, type); /* First we compare memory layout. */ if (!odr_types_equivalent_p (val->type, type, !flag_ltrans && !val->odr_violated, - &warned, visited)) + &warned, &visited)) { merge = false; odr_violation_reported = true; @@ -979,7 +984,6 @@ add_type_duplicate (odr_type val, tree type) putc ('\n',cgraph_dump_file); } } - pointer_set_destroy (visited); /* Next sanity check that bases are the same. If not, we will end up producing wrong answers. */ @@ -1355,7 +1359,7 @@ referenced_from_vtable_p (struct cgraph_node *node) static void maybe_record_node (vec &nodes, - tree target, pointer_set_t *inserted, + tree target, hash_set *inserted, bool can_refer, bool *completep) { @@ -1421,10 +1425,9 @@ maybe_record_node (vec &nodes, { gcc_assert (!target_node->global.inlined_to); gcc_assert (target_node->real_symbol_p ()); - if (!pointer_set_insert (inserted, target_node->decl)) + if (!inserted->add (target)) { - pointer_set_insert (cached_polymorphic_call_targets, - target_node); + cached_polymorphic_call_targets->add (target_node); nodes.safe_push (target_node); } } @@ -1464,8 +1467,8 @@ record_target_from_binfo (vec &nodes, HOST_WIDE_INT otr_token, tree outer_type, HOST_WIDE_INT offset, - pointer_set_t *inserted, - pointer_set_t *matched_vtables, + hash_set *inserted, + hash_set *matched_vtables, bool anonymous, bool *completep) { @@ -1518,8 +1521,8 @@ record_target_from_binfo (vec &nodes, } gcc_assert (inner_binfo); if (bases_to_consider - ? !pointer_set_contains (matched_vtables, BINFO_VTABLE (inner_binfo)) - : !pointer_set_insert (matched_vtables, BINFO_VTABLE (inner_binfo))) + ? !matched_vtables->contains (BINFO_VTABLE (inner_binfo)) + : !matched_vtables->add (BINFO_VTABLE (inner_binfo))) { bool can_refer; tree target = gimple_get_virt_method_for_binfo (otr_token, @@ -1558,8 +1561,8 @@ record_target_from_binfo (vec &nodes, static void possible_polymorphic_call_targets_1 (vec &nodes, - pointer_set_t *inserted, - pointer_set_t *matched_vtables, + hash_set *inserted, + hash_set *matched_vtables, tree otr_type, odr_type type, HOST_WIDE_INT otr_token, @@ -1612,8 +1615,10 @@ struct polymorphic_call_target_d ipa_polymorphic_call_context context; odr_type type; vec targets; - int nonconstruction_targets; + int speculative_targets; bool complete; + int type_warning; + tree decl_warning; }; /* Polymorphic call target cache helpers. */ @@ -1632,17 +1637,22 @@ struct polymorphic_call_target_hasher inline hashval_t polymorphic_call_target_hasher::hash (const value_type *odr_query) { - hashval_t hash; + inchash::hash hstate (odr_query->otr_token); + + hstate.add_wide_int (odr_query->type->id); + hstate.merge_hash (TYPE_UID (odr_query->context.outer_type)); + hstate.add_wide_int (odr_query->context.offset); - hash = iterative_hash_host_wide_int - (odr_query->otr_token, - odr_query->type->id); - hash = iterative_hash_hashval_t (TYPE_UID (odr_query->context.outer_type), - hash); - hash = iterative_hash_host_wide_int (odr_query->context.offset, hash); - return iterative_hash_hashval_t - (((int)odr_query->context.maybe_in_construction << 1) - | (int)odr_query->context.maybe_derived_type, hash); + if (odr_query->context.speculative_outer_type) + { + hstate.merge_hash (TYPE_UID (odr_query->context.speculative_outer_type)); + hstate.add_wide_int (odr_query->context.speculative_offset); + } + hstate.add_flag (odr_query->context.maybe_in_construction); + hstate.add_flag (odr_query->context.maybe_derived_type); + hstate.add_flag (odr_query->context.speculative_maybe_derived_type); + hstate.commit_flag (); + return hstate.end (); } /* Compare cache entries T1 and T2. */ @@ -1653,10 +1663,14 @@ polymorphic_call_target_hasher::equal (const value_type *t1, { return (t1->type == t2->type && t1->otr_token == t2->otr_token && t1->context.offset == t2->context.offset + && t1->context.speculative_offset == t2->context.speculative_offset && t1->context.outer_type == t2->context.outer_type + && t1->context.speculative_outer_type == t2->context.speculative_outer_type && t1->context.maybe_in_construction == t2->context.maybe_in_construction - && t1->context.maybe_derived_type == t2->context.maybe_derived_type); + && t1->context.maybe_derived_type == t2->context.maybe_derived_type + && (t1->context.speculative_maybe_derived_type + == t2->context.speculative_maybe_derived_type)); } /* Remove entry in polymorphic call target cache hash. */ @@ -1683,7 +1697,7 @@ free_polymorphic_call_targets_hash () { delete polymorphic_call_target_hash; polymorphic_call_target_hash = NULL; - pointer_set_destroy (cached_polymorphic_call_targets); + delete cached_polymorphic_call_targets; cached_polymorphic_call_targets = NULL; } } @@ -1694,7 +1708,7 @@ static void devirt_node_removal_hook (struct cgraph_node *n, void *d ATTRIBUTE_UNUSED) { if (cached_polymorphic_call_targets - && pointer_set_contains (cached_polymorphic_call_targets, n)) + && cached_polymorphic_call_targets->contains (n)) free_polymorphic_call_targets_hash (); } @@ -1723,6 +1737,16 @@ contains_polymorphic_type_p (const_tree type) return false; } +/* Clear speculative info from CONTEXT. */ + +static void +clear_speculation (ipa_polymorphic_call_context *context) +{ + context->speculative_outer_type = NULL; + context->speculative_offset = 0; + context->speculative_maybe_derived_type = false; +} + /* CONTEXT->OUTER_TYPE is a type of memory object where object of EXPECTED_TYPE is contained at CONTEXT->OFFSET. Walk the memory representation of CONTEXT->OUTER_TYPE and find the outermost class type that match @@ -1749,9 +1773,48 @@ get_class_context (ipa_polymorphic_call_context *context, { tree type = context->outer_type; HOST_WIDE_INT offset = context->offset; - + bool speculative = false; + bool speculation_valid = false; + bool valid = false; + + if (!context->outer_type) + { + type = context->outer_type = expected_type; + context->offset = offset = 0; + } + + if (context->speculative_outer_type == context->outer_type + && (!context->maybe_derived_type + || context->speculative_maybe_derived_type)) + { + context->speculative_outer_type = NULL; + context->speculative_offset = 0; + context->speculative_maybe_derived_type = false; + } + + /* See if speculative type seem to be derrived from outer_type. + Then speculation is valid only if it really is a derivate and derived types + are allowed. + + The test does not really look for derivate, but also accepts the case where + outer_type is a field of speculative_outer_type. In this case eiter + MAYBE_DERIVED_TYPE is false and we have full non-speculative information or + the loop bellow will correctly update SPECULATIVE_OUTER_TYPE + and SPECULATIVE_MAYBE_DERIVED_TYPE. */ + if (context->speculative_outer_type + && context->speculative_offset >= context->offset + && contains_type_p (context->speculative_outer_type, + context->offset - context->speculative_offset, + context->outer_type)) + speculation_valid = context->maybe_derived_type; + else + clear_speculation (context); + /* Find the sub-object the constant actually refers to and mark whether it is - an artificial one (as opposed to a user-defined one). */ + an artificial one (as opposed to a user-defined one). + + This loop is performed twice; first time for outer_type and second time + for speculative_outer_type. The second iteration has SPECULATIVE set. */ while (true) { HOST_WIDE_INT pos, size; @@ -1759,14 +1822,53 @@ get_class_context (ipa_polymorphic_call_context *context, /* On a match, just return what we found. */ if (TREE_CODE (type) == TREE_CODE (expected_type) + && (!in_lto_p + || (TREE_CODE (type) == RECORD_TYPE + && TYPE_BINFO (type) + && polymorphic_type_binfo_p (TYPE_BINFO (type)))) && types_same_for_odr (type, expected_type)) { - /* Type can not contain itself on an non-zero offset. In that case - just give up. */ - if (offset != 0) - goto give_up; - gcc_assert (offset == 0); - return true; + if (speculative) + { + gcc_assert (speculation_valid); + gcc_assert (valid); + + /* If we did not match the offset, just give up on speculation. */ + if (offset != 0 + || (types_same_for_odr (context->speculative_outer_type, + context->outer_type) + && (context->maybe_derived_type + == context->speculative_maybe_derived_type))) + clear_speculation (context); + return true; + } + else + { + /* Type can not contain itself on an non-zero offset. In that case + just give up. */ + if (offset != 0) + { + valid = false; + goto give_up; + } + valid = true; + /* If speculation is not valid or we determined type precisely, + we are done. */ + if (!speculation_valid + || !context->maybe_derived_type) + { + clear_speculation (context); + return true; + } + /* Otherwise look into speculation now. */ + else + { + speculative = true; + type = context->speculative_outer_type; + offset = context->speculative_offset; + continue; + } + } } /* Walk fields and find corresponding on at OFFSET. */ @@ -1791,11 +1893,20 @@ get_class_context (ipa_polymorphic_call_context *context, /* DECL_ARTIFICIAL represents a basetype. */ if (!DECL_ARTIFICIAL (fld)) { - context->outer_type = type; - context->offset = offset; - /* As soon as we se an field containing the type, - we know we are not looking for derivations. */ - context->maybe_derived_type = false; + if (!speculative) + { + context->outer_type = type; + context->offset = offset; + /* As soon as we se an field containing the type, + we know we are not looking for derivations. */ + context->maybe_derived_type = false; + } + else + { + context->speculative_outer_type = type; + context->speculative_offset = offset; + context->speculative_maybe_derived_type = false; + } } } else if (TREE_CODE (type) == ARRAY_TYPE) @@ -1808,9 +1919,18 @@ get_class_context (ipa_polymorphic_call_context *context, goto give_up; offset = offset % tree_to_shwi (TYPE_SIZE (subtype)); type = subtype; - context->outer_type = type; - context->offset = offset; - context->maybe_derived_type = false; + if (!speculative) + { + context->outer_type = type; + context->offset = offset; + context->maybe_derived_type = false; + } + else + { + context->speculative_outer_type = type; + context->speculative_offset = offset; + context->speculative_maybe_derived_type = false; + } } /* Give up on anything else. */ else @@ -1820,6 +1940,9 @@ get_class_context (ipa_polymorphic_call_context *context, /* If we failed to find subtype we look for, give up and fall back to the most generic query. */ give_up: + clear_speculation (context); + if (valid) + return true; context->outer_type = expected_type; context->offset = 0; context->maybe_derived_type = true; @@ -1830,7 +1953,8 @@ give_up: if ((TREE_CODE (type) != RECORD_TYPE || !TYPE_BINFO (type) || !polymorphic_type_binfo_p (TYPE_BINFO (type))) - && (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST + && (!TYPE_SIZE (type) + || TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST || (offset + tree_to_uhwi (TYPE_SIZE (expected_type)) <= tree_to_uhwi (TYPE_SIZE (type))))) return true; @@ -1843,9 +1967,9 @@ static bool contains_type_p (tree outer_type, HOST_WIDE_INT offset, tree otr_type) { - ipa_polymorphic_call_context context = {offset, + ipa_polymorphic_call_context context = {offset, 0, TYPE_MAIN_VARIANT (outer_type), - false, true}; + NULL, false, true, false}; return get_class_context (&context, otr_type); } @@ -2053,6 +2177,9 @@ get_polymorphic_call_info_for_decl (ipa_polymorphic_call_context *context, context->outer_type = TYPE_MAIN_VARIANT (TREE_TYPE (base)); context->offset = offset; + context->speculative_outer_type = NULL; + context->speculative_offset = 0; + context->speculative_maybe_derived_type = true; /* Make very conservative assumption that all objects may be in construction. TODO: ipa-prop already contains code to tell better. @@ -2092,6 +2219,26 @@ get_polymorphic_call_info_from_invariant (ipa_polymorphic_call_context *context, return true; } +/* See if OP is SSA name initialized as a copy or by single assignment. + If so, walk the SSA graph up. */ + +static tree +walk_ssa_copies (tree op) +{ + STRIP_NOPS (op); + while (TREE_CODE (op) == SSA_NAME + && !SSA_NAME_IS_DEFAULT_DEF (op) + && SSA_NAME_DEF_STMT (op) + && gimple_assign_single_p (SSA_NAME_DEF_STMT (op))) + { + if (gimple_assign_load_p (SSA_NAME_DEF_STMT (op))) + return op; + op = gimple_assign_rhs1 (SSA_NAME_DEF_STMT (op)); + STRIP_NOPS (op); + } + return op; +} + /* Given REF call in FNDECL, determine class of the polymorphic call (OTR_TYPE), its token (OTR_TOKEN) and CONTEXT. CALL is optional argument giving the actual statement (usually call) where @@ -2111,6 +2258,9 @@ get_polymorphic_call_info (tree fndecl, *otr_token = tree_to_uhwi (OBJ_TYPE_REF_TOKEN (ref)); /* Set up basic info in case we find nothing interesting in the analysis. */ + context->speculative_outer_type = NULL; + context->speculative_offset = 0; + context->speculative_maybe_derived_type = true; context->outer_type = TYPE_MAIN_VARIANT (*otr_type); context->offset = 0; base_pointer = OBJ_TYPE_REF_OBJECT (ref); @@ -2120,15 +2270,8 @@ get_polymorphic_call_info (tree fndecl, /* Walk SSA for outer object. */ do { - if (TREE_CODE (base_pointer) == SSA_NAME - && !SSA_NAME_IS_DEFAULT_DEF (base_pointer) - && SSA_NAME_DEF_STMT (base_pointer) - && gimple_assign_single_p (SSA_NAME_DEF_STMT (base_pointer))) - { - base_pointer = gimple_assign_rhs1 (SSA_NAME_DEF_STMT (base_pointer)); - STRIP_NOPS (base_pointer); - } - else if (TREE_CODE (base_pointer) == ADDR_EXPR) + base_pointer = walk_ssa_copies (base_pointer); + if (TREE_CODE (base_pointer) == ADDR_EXPR) { HOST_WIDE_INT size, max_size; HOST_WIDE_INT offset2; @@ -2174,7 +2317,7 @@ get_polymorphic_call_info (tree fndecl, context->outer_type, call, current_function_decl); - return NULL; + return base_pointer; } else break; @@ -2258,6 +2401,35 @@ get_polymorphic_call_info (tree fndecl, return base_pointer; } } + + tree base_type = TREE_TYPE (base_pointer); + + if (TREE_CODE (base_pointer) == SSA_NAME + && SSA_NAME_IS_DEFAULT_DEF (base_pointer) + && TREE_CODE (SSA_NAME_VAR (base_pointer)) != PARM_DECL) + { + /* Use OTR_TOKEN = INT_MAX as a marker of probably type inconsistent + code sequences; we arrange the calls to be builtin_unreachable + later. */ + *otr_token = INT_MAX; + return base_pointer; + } + if (TREE_CODE (base_pointer) == SSA_NAME + && SSA_NAME_DEF_STMT (base_pointer) + && gimple_assign_single_p (SSA_NAME_DEF_STMT (base_pointer))) + base_type = TREE_TYPE (gimple_assign_rhs1 + (SSA_NAME_DEF_STMT (base_pointer))); + + if (POINTER_TYPE_P (base_type) + && contains_type_p (TYPE_MAIN_VARIANT (TREE_TYPE (base_type)), + context->offset, + *otr_type)) + { + context->speculative_outer_type = TYPE_MAIN_VARIANT + (TREE_TYPE (base_type)); + context->speculative_offset = context->offset; + context->speculative_maybe_derived_type = true; + } /* TODO: There are multiple ways to derive a type. For instance if BASE_POINTER is passed to an constructor call prior our refernece. We do not make this type of flow sensitive analysis yet. */ @@ -2276,8 +2448,8 @@ record_targets_from_bases (tree otr_type, tree outer_type, HOST_WIDE_INT offset, vec &nodes, - pointer_set_t *inserted, - pointer_set_t *matched_vtables, + hash_set *inserted, + hash_set *matched_vtables, bool *completep) { while (true) @@ -2318,7 +2490,7 @@ record_targets_from_bases (tree otr_type, return; } gcc_assert (base_binfo); - if (!pointer_set_insert (matched_vtables, BINFO_VTABLE (base_binfo))) + if (!matched_vtables->add (BINFO_VTABLE (base_binfo))) { bool can_refer; tree target = gimple_get_virt_method_for_binfo (otr_token, @@ -2326,7 +2498,7 @@ record_targets_from_bases (tree otr_type, &can_refer); if (!target || ! DECL_CXX_DESTRUCTOR_P (target)) maybe_record_node (nodes, target, inserted, can_refer, completep); - pointer_set_insert (matched_vtables, BINFO_VTABLE (base_binfo)); + matched_vtables->add (BINFO_VTABLE (base_binfo)); } } } @@ -2343,6 +2515,31 @@ devirt_variable_node_removal_hook (varpool_node *n, free_polymorphic_call_targets_hash (); } +/* Record about how many calls would benefit from given type to be final. */ +struct odr_type_warn_count +{ + tree type; + int count; + gcov_type dyn_count; +}; + +/* Record about how many calls would benefit from given method to be final. */ +struct decl_warn_count +{ + tree decl; + int count; + gcov_type dyn_count; +}; + +/* Information about type and decl warnings. */ +struct final_warning_record +{ + gcov_type dyn_count; + vec type_warnings; + hash_map decl_warnings; +}; +struct final_warning_record *final_warning_records; + /* Return vector containing possible targets of polymorphic call of type OTR_TYPE caling method OTR_TOKEN within type of OTR_OUTER_TYPE and OFFSET. If INCLUDE_BASES is true, walk also base types of OUTER_TYPES containig @@ -2359,9 +2556,10 @@ devirt_variable_node_removal_hook (varpool_node *n, in the target cache. If user needs to visit every target list just once, it can memoize them. - NONCONSTRUCTION_TARGETS specify number of targets with asumption that - the type is not in the construction. Those targets appear first in the - vector returned. + SPECULATION_TARGETS specify number of targets that are speculatively + likely. These include targets specified by the speculative part + of polymoprhic call context and also exclude all targets for classes + in construction. Returned vector is placed into cache. It is NOT caller's responsibility to free it. The vector can be freed on cgraph_remove_node call if @@ -2373,11 +2571,9 @@ possible_polymorphic_call_targets (tree otr_type, ipa_polymorphic_call_context context, bool *completep, void **cache_token, - int *nonconstruction_targetsp) + int *speculative_targetsp) { static struct cgraph_node_hook_list *node_removal_hook_holder; - pointer_set_t *inserted; - pointer_set_t *matched_vtables; vec nodes = vNULL; vec bases_to_consider = vNULL; odr_type type, outer_type; @@ -2398,8 +2594,8 @@ possible_polymorphic_call_targets (tree otr_type, *completep = false; if (cache_token) *cache_token = NULL; - if (nonconstruction_targetsp) - *nonconstruction_targetsp = 0; + if (speculative_targetsp) + *speculative_targetsp = 0; return nodes; } @@ -2410,11 +2606,15 @@ possible_polymorphic_call_targets (tree otr_type, *completep = true; if (cache_token) *cache_token = NULL; - if (nonconstruction_targetsp) - *nonconstruction_targetsp = 0; + if (speculative_targetsp) + *speculative_targetsp = 0; return nodes; } + /* Do not bother to compute speculative info when user do not asks for it. */ + if (!speculative_targetsp || !context.speculative_outer_type) + clear_speculation (&context); + type = get_odr_type (otr_type, true); /* Recording type variants would wast results cache. */ @@ -2422,15 +2622,15 @@ possible_polymorphic_call_targets (tree otr_type, || TYPE_MAIN_VARIANT (context.outer_type) == context.outer_type); /* Lookup the outer class type we want to walk. */ - if (context.outer_type + if ((context.outer_type || context.speculative_outer_type) && !get_class_context (&context, otr_type)) { if (completep) *completep = false; if (cache_token) *cache_token = NULL; - if (nonconstruction_targetsp) - *nonconstruction_targetsp = 0; + if (speculative_targetsp) + *speculative_targetsp = 0; return nodes; } @@ -2456,7 +2656,7 @@ possible_polymorphic_call_targets (tree otr_type, /* Initialize query cache. */ if (!cached_polymorphic_call_targets) { - cached_polymorphic_call_targets = pointer_set_create (); + cached_polymorphic_call_targets = new hash_set; polymorphic_call_target_hash = new polymorphic_call_target_hash_type (23); if (!node_removal_hook_holder) @@ -2479,8 +2679,21 @@ possible_polymorphic_call_targets (tree otr_type, { if (completep) *completep = (*slot)->complete; - if (nonconstruction_targetsp) - *nonconstruction_targetsp = (*slot)->nonconstruction_targets; + if (speculative_targetsp) + *speculative_targetsp = (*slot)->speculative_targets; + if ((*slot)->type_warning && final_warning_records) + { + final_warning_records->type_warnings[(*slot)->type_warning - 1].count++; + final_warning_records->type_warnings[(*slot)->type_warning - 1].dyn_count + += final_warning_records->dyn_count; + } + if ((*slot)->decl_warning && final_warning_records) + { + struct decl_warn_count *c = + final_warning_records->decl_warnings.get ((*slot)->decl_warning); + c->count++; + c->dyn_count += final_warning_records->dyn_count; + } return (*slot)->targets; } @@ -2494,9 +2707,53 @@ possible_polymorphic_call_targets (tree otr_type, (*slot)->type = type; (*slot)->otr_token = otr_token; (*slot)->context = context; + (*slot)->speculative_targets = 0; + + hash_set inserted; + hash_set matched_vtables; - inserted = pointer_set_create (); - matched_vtables = pointer_set_create (); + /* First insert targets we speculatively identified as likely. */ + if (context.speculative_outer_type) + { + odr_type speculative_outer_type; + bool speculation_complete = true; + + /* First insert target from type itself and check if it may have derived types. */ + speculative_outer_type = get_odr_type (context.speculative_outer_type, true); + if (TYPE_FINAL_P (speculative_outer_type->type)) + context.speculative_maybe_derived_type = false; + binfo = get_binfo_at_offset (TYPE_BINFO (speculative_outer_type->type), + context.speculative_offset, otr_type); + if (binfo) + target = gimple_get_virt_method_for_binfo (otr_token, binfo, + &can_refer); + else + target = NULL; + + /* In the case we get complete method, we don't need + to walk derivations. */ + if (target && DECL_FINAL_P (target)) + context.speculative_maybe_derived_type = false; + if (type_possibly_instantiated_p (speculative_outer_type->type)) + maybe_record_node (nodes, target, &inserted, can_refer, &speculation_complete); + if (binfo) + matched_vtables.add (BINFO_VTABLE (binfo)); + + + /* Next walk recursively all derived types. */ + if (context.speculative_maybe_derived_type) + for (i = 0; i < speculative_outer_type->derived_types.length(); i++) + possible_polymorphic_call_targets_1 (nodes, &inserted, + &matched_vtables, + otr_type, + speculative_outer_type->derived_types[i], + otr_token, speculative_outer_type->type, + context.speculative_offset, + &speculation_complete, + bases_to_consider, + false); + (*slot)->speculative_targets = nodes.length(); + } /* First see virtual method of type itself. */ binfo = get_binfo_at_offset (TYPE_BINFO (outer_type->type), @@ -2525,7 +2782,7 @@ possible_polymorphic_call_targets (tree otr_type, /* If OUTER_TYPE is abstract, we know we are not seeing its instance. */ if (type_possibly_instantiated_p (outer_type->type)) - maybe_record_node (nodes, target, inserted, can_refer, &complete); + maybe_record_node (nodes, target, &inserted, can_refer, &complete); else { skipped = true; @@ -2533,28 +2790,72 @@ possible_polymorphic_call_targets (tree otr_type, } if (binfo) - pointer_set_insert (matched_vtables, BINFO_VTABLE (binfo)); + matched_vtables.add (BINFO_VTABLE (binfo)); /* Next walk recursively all derived types. */ if (context.maybe_derived_type) { - /* For anonymous namespace types we can attempt to build full type. - All derivations must be in this unit (unless we see partial unit). */ - if (!type->all_derivations_known) - complete = false; for (i = 0; i < outer_type->derived_types.length(); i++) - possible_polymorphic_call_targets_1 (nodes, inserted, - matched_vtables, + possible_polymorphic_call_targets_1 (nodes, &inserted, + &matched_vtables, otr_type, outer_type->derived_types[i], otr_token, outer_type->type, context.offset, &complete, bases_to_consider, context.maybe_in_construction); + + if (!outer_type->all_derivations_known) + { + if (final_warning_records) + { + if (complete + && nodes.length () == 1 + && warn_suggest_final_types + && !outer_type->derived_types.length ()) + { + if (outer_type->id >= (int)final_warning_records->type_warnings.length ()) + final_warning_records->type_warnings.safe_grow_cleared + (odr_types.length ()); + final_warning_records->type_warnings[outer_type->id].count++; + final_warning_records->type_warnings[outer_type->id].dyn_count + += final_warning_records->dyn_count; + final_warning_records->type_warnings[outer_type->id].type + = outer_type->type; + (*slot)->type_warning = outer_type->id + 1; + } + if (complete + && warn_suggest_final_methods + && nodes.length () == 1 + && types_same_for_odr (DECL_CONTEXT (nodes[0]->decl), + outer_type->type)) + { + bool existed; + struct decl_warn_count &c = + final_warning_records->decl_warnings.get_or_insert + (nodes[0]->decl, &existed); + + if (existed) + { + c.count++; + c.dyn_count += final_warning_records->dyn_count; + } + else + { + c.count = 1; + c.dyn_count = final_warning_records->dyn_count; + c.decl = nodes[0]->decl; + } + (*slot)->decl_warning = nodes[0]->decl; + } + } + complete = false; + } } /* Finally walk bases, if asked to. */ - (*slot)->nonconstruction_targets = nodes.length(); + if (!(*slot)->speculative_targets) + (*slot)->speculative_targets = nodes.length(); /* Destructors are never called through construction virtual tables, because the type is always known. One of entries may be cxa_pure_virtual @@ -2570,12 +2871,12 @@ possible_polymorphic_call_targets (tree otr_type, || (context.maybe_derived_type && !type_all_derivations_known_p (outer_type->type)))) record_targets_from_bases (otr_type, otr_token, outer_type->type, - context.offset, nodes, inserted, - matched_vtables, &complete); + context.offset, nodes, &inserted, + &matched_vtables, &complete); if (skipped) - maybe_record_node (nodes, target, inserted, can_refer, &complete); + maybe_record_node (nodes, target, &inserted, can_refer, &complete); for (i = 0; i < bases_to_consider.length(); i++) - maybe_record_node (nodes, bases_to_consider[i], inserted, can_refer, &complete); + maybe_record_node (nodes, bases_to_consider[i], &inserted, can_refer, &complete); } bases_to_consider.release(); @@ -2583,15 +2884,21 @@ possible_polymorphic_call_targets (tree otr_type, (*slot)->complete = complete; if (completep) *completep = complete; - if (nonconstruction_targetsp) - *nonconstruction_targetsp = (*slot)->nonconstruction_targets; + if (speculative_targetsp) + *speculative_targetsp = (*slot)->speculative_targets; - pointer_set_destroy (inserted); - pointer_set_destroy (matched_vtables); timevar_pop (TV_IPA_VIRTUAL_CALL); return nodes; } +bool +add_decl_warning (const tree &key ATTRIBUTE_UNUSED, const decl_warn_count &value, + vec *vec) +{ + vec->safe_push (&value); + return true; +} + /* Dump all possible targets of a polymorphic call. */ void @@ -2604,13 +2911,13 @@ dump_possible_polymorphic_call_targets (FILE *f, bool final; odr_type type = get_odr_type (TYPE_MAIN_VARIANT (otr_type), false); unsigned int i; - int nonconstruction; + int speculative; if (!type) return; targets = possible_polymorphic_call_targets (otr_type, otr_token, ctx, - &final, NULL, &nonconstruction); + &final, NULL, &speculative); fprintf (f, " Targets of polymorphic call of type %i:", type->id); print_generic_expr (f, type->type, TDF_SLIM); fprintf (f, " token %i\n", (int)otr_token); @@ -2621,18 +2928,25 @@ dump_possible_polymorphic_call_targets (FILE *f, fprintf (f, " at offset "HOST_WIDE_INT_PRINT_DEC"\n", ctx.offset); } + if (ctx.speculative_outer_type) + { + fprintf (f, " Speculatively contained in type:"); + print_generic_expr (f, ctx.speculative_outer_type, TDF_SLIM); + fprintf (f, " at offset "HOST_WIDE_INT_PRINT_DEC"\n", + ctx.speculative_offset); + } - fprintf (f, " %s%s%s\n ", + fprintf (f, " %s%s%s%s\n ", final ? "This is a complete list." : "This is partial list; extra targets may be defined in other units.", ctx.maybe_in_construction ? " (base types included)" : "", - ctx.maybe_derived_type ? " (derived types included)" : ""); + ctx.maybe_derived_type ? " (derived types included)" : "", + ctx.speculative_maybe_derived_type ? " (speculative derived types included)" : ""); for (i = 0; i < targets.length (); i++) { char *name = NULL; - if (i == (unsigned)nonconstruction) - fprintf (f, "\n If the type is in construction," - " then additional tarets are:\n" + if (i == (unsigned)speculative) + fprintf (f, "\n Targets that are not likely:\n" " "); if (in_lto_p) name = cplus_demangle_v3 (targets[i]->asm_name (), 0); @@ -2735,6 +3049,38 @@ likely_target_p (struct cgraph_node *n) return true; } +/* Compare type warning records P1 and P2 and chose one with larger count; + helper for qsort. */ + +int +type_warning_cmp (const void *p1, const void *p2) +{ + const odr_type_warn_count *t1 = (const odr_type_warn_count *)p1; + const odr_type_warn_count *t2 = (const odr_type_warn_count *)p2; + + if (t1->dyn_count < t2->dyn_count) + return 1; + if (t1->dyn_count > t2->dyn_count) + return -1; + return t2->count - t1->count; +} + +/* Compare decl warning records P1 and P2 and chose one with larger count; + helper for qsort. */ + +int +decl_warning_cmp (const void *p1, const void *p2) +{ + const decl_warn_count *t1 = *(const decl_warn_count * const *)p1; + const decl_warn_count *t2 = *(const decl_warn_count * const *)p2; + + if (t1->dyn_count < t2->dyn_count) + return 1; + if (t1->dyn_count > t2->dyn_count) + return -1; + return t2->count - t1->count; +} + /* The ipa-devirt pass. When polymorphic call has only one likely target in the unit, turn it into speculative call. */ @@ -2743,13 +3089,26 @@ static unsigned int ipa_devirt (void) { struct cgraph_node *n; - struct pointer_set_t *bad_call_targets = pointer_set_create (); + hash_set bad_call_targets; struct cgraph_edge *e; int npolymorphic = 0, nspeculated = 0, nconverted = 0, ncold = 0; int nmultiple = 0, noverwritable = 0, ndevirtualized = 0, nnotdefined = 0; int nwrong = 0, nok = 0, nexternal = 0, nartificial = 0; + /* We can output -Wsuggest-final-methods and -Wsuggest-final-types warnings. + This is implemented by setting up final_warning_records that are updated + by get_polymorphic_call_targets. + We need to clear cache in this case to trigger recomputation of all + entries. */ + if (warn_suggest_final_methods || warn_suggest_final_types) + { + final_warning_records = new (final_warning_record); + final_warning_records->type_warnings = vNULL; + final_warning_records->type_warnings.safe_grow_cleared (odr_types.length ()); + free_polymorphic_call_targets_hash (); + } + FOR_EACH_DEFINED_FUNCTION (n) { bool update = false; @@ -2762,10 +3121,14 @@ ipa_devirt (void) struct cgraph_node *likely_target = NULL; void *cache_token; bool final; - int nonconstruction_targets; + int speculative_targets; + + if (final_warning_records) + final_warning_records->dyn_count = e->count; + vec targets = possible_polymorphic_call_targets - (e, &final, &cache_token, &nonconstruction_targets); + (e, &final, &cache_token, &speculative_targets); unsigned int i; if (dump_file) @@ -2774,6 +3137,9 @@ ipa_devirt (void) npolymorphic++; + if (!flag_devirtualize_speculatively) + continue; + if (!cgraph_maybe_hot_edge_p (e)) { if (dump_file) @@ -2791,8 +3157,7 @@ ipa_devirt (void) if (!dump_file) continue; } - if (pointer_set_contains (bad_call_targets, - cache_token)) + if (bad_call_targets.contains (cache_token)) { if (dump_file) fprintf (dump_file, "Target list is known to be useless\n\n"); @@ -2804,7 +3169,7 @@ ipa_devirt (void) { if (likely_target) { - if (i < (unsigned) nonconstruction_targets) + if (i < (unsigned) speculative_targets) { likely_target = NULL; if (dump_file) @@ -2817,7 +3182,7 @@ ipa_devirt (void) } if (!likely_target) { - pointer_set_insert (bad_call_targets, cache_token); + bad_call_targets.add (cache_token); continue; } /* This is reached only when dumping; check if we agree or disagree @@ -2904,7 +3269,55 @@ ipa_devirt (void) if (update) inline_update_overall_summary (n); } - pointer_set_destroy (bad_call_targets); + if (warn_suggest_final_methods || warn_suggest_final_types) + { + if (warn_suggest_final_types) + { + final_warning_records->type_warnings.qsort (type_warning_cmp); + for (unsigned int i = 0; + i < final_warning_records->type_warnings.length (); i++) + if (final_warning_records->type_warnings[i].count) + { + tree type = final_warning_records->type_warnings[i].type; + warning_at (DECL_SOURCE_LOCATION (TYPE_NAME (type)), + OPT_Wsuggest_final_types, + "Declaring type %qD final " + "would enable devirtualization of %i calls", + type, + final_warning_records->type_warnings[i].count); + } + } + + if (warn_suggest_final_methods) + { + vec decl_warnings_vec = vNULL; + + final_warning_records->decl_warnings.traverse + *, add_decl_warning> (&decl_warnings_vec); + decl_warnings_vec.qsort (decl_warning_cmp); + for (unsigned int i = 0; i < decl_warnings_vec.length (); i++) + { + tree decl = decl_warnings_vec[i]->decl; + int count = decl_warnings_vec[i]->count; + + if (DECL_CXX_DESTRUCTOR_P (decl)) + warning_at (DECL_SOURCE_LOCATION (decl), + OPT_Wsuggest_final_methods, + "Declaring virtual destructor of %qD final " + "would enable devirtualization of %i calls", + DECL_CONTEXT (decl), count); + else + warning_at (DECL_SOURCE_LOCATION (decl), + OPT_Wsuggest_final_methods, + "Declaring method %qD final " + "would enable devirtualization of %i calls", + decl, count); + } + } + + delete (final_warning_records); + final_warning_records = 0; + } if (dump_file) fprintf (dump_file, @@ -2954,7 +3367,9 @@ public: virtual bool gate (function *) { return (flag_devirtualize - && flag_devirtualize_speculatively + && (flag_devirtualize_speculatively + || (warn_suggest_final_methods + || warn_suggest_final_types)) && optimize); } diff --git a/main/gcc/ipa-inline-transform.c b/main/gcc/ipa-inline-transform.c index caf794b49d6..00639f1b816 100644 --- a/main/gcc/ipa-inline-transform.c +++ b/main/gcc/ipa-inline-transform.c @@ -103,7 +103,7 @@ can_remove_node_now_p_1 (struct cgraph_node *node) && !DECL_VIRTUAL_P (node->decl) /* During early inlining some unanalyzed cgraph nodes might be in the callgraph and they might reffer the function in question. */ - && !cgraph_new_nodes); + && !cgraph_new_nodes.exists ()); } /* We are going to eliminate last direct call to NODE (or alias of it) via edge E. diff --git a/main/gcc/ipa-prop.c b/main/gcc/ipa-prop.c index 74654262c3e..298f229d787 100644 --- a/main/gcc/ipa-prop.c +++ b/main/gcc/ipa-prop.c @@ -213,7 +213,7 @@ ipa_populate_param_decls (struct cgraph_node *node, /* Return how many formal parameters FNDECL has. */ -static inline int +int count_formal_params (tree fndecl) { tree parm; @@ -4710,6 +4710,7 @@ ipa_write_indirect_edge_info (struct output_block *ob, bp_pack_value (&bp, ii->by_ref, 1); bp_pack_value (&bp, ii->maybe_in_construction, 1); bp_pack_value (&bp, ii->maybe_derived_type, 1); + bp_pack_value (&bp, ii->speculative_maybe_derived_type, 1); streamer_write_bitpack (&bp); if (ii->polymorphic) @@ -4717,6 +4718,9 @@ ipa_write_indirect_edge_info (struct output_block *ob, streamer_write_hwi (ob, ii->otr_token); stream_write_tree (ob, ii->otr_type, true); stream_write_tree (ob, ii->outer_type, true); + stream_write_tree (ob, ii->speculative_outer_type, true); + if (ii->speculative_outer_type) + streamer_write_hwi (ob, ii->speculative_offset); } } @@ -4740,11 +4744,15 @@ ipa_read_indirect_edge_info (struct lto_input_block *ib, ii->by_ref = bp_unpack_value (&bp, 1); ii->maybe_in_construction = bp_unpack_value (&bp, 1); ii->maybe_derived_type = bp_unpack_value (&bp, 1); + ii->speculative_maybe_derived_type = bp_unpack_value (&bp, 1); if (ii->polymorphic) { ii->otr_token = (HOST_WIDE_INT) streamer_read_hwi (ib); ii->otr_type = stream_read_tree (ib, data_in); ii->outer_type = stream_read_tree (ib, data_in); + ii->speculative_outer_type = stream_read_tree (ib, data_in); + if (ii->speculative_outer_type) + ii->speculative_offset = (HOST_WIDE_INT) streamer_read_hwi (ib); } } diff --git a/main/gcc/ipa-prop.h b/main/gcc/ipa-prop.h index 3717394eb46..e5e826851fc 100644 --- a/main/gcc/ipa-prop.h +++ b/main/gcc/ipa-prop.h @@ -529,6 +529,7 @@ void ipa_free_all_edge_args (void); void ipa_free_all_structures_after_ipa_cp (void); void ipa_free_all_structures_after_iinln (void); void ipa_register_cgraph_hooks (void); +int count_formal_params (tree fndecl); /* This function ensures the array of node param infos is big enough to accommodate a structure for all nodes and reallocates it if not. */ diff --git a/main/gcc/ipa-pure-const.c b/main/gcc/ipa-pure-const.c index 08369b2a5d7..e9bf36383f0 100644 --- a/main/gcc/ipa-pure-const.c +++ b/main/gcc/ipa-pure-const.c @@ -65,8 +65,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-scalar-evolution.h" #include "intl.h" #include "opts.h" - -static struct pointer_set_t *visited_nodes; +#include "hash-set.h" /* Lattice values for const and pure functions. Everything starts out being const, then may drop to pure and then neither depending on @@ -133,13 +132,13 @@ function_always_visible_to_compiler_p (tree decl) /* Emit suggestion about attribute ATTRIB_NAME for DECL. KNOWN_FINITE is true if the function is known to be finite. The diagnostic is - controlled by OPTION. WARNED_ABOUT is a pointer_set unique for + controlled by OPTION. WARNED_ABOUT is a hash_set unique for OPTION, this function may initialize it and it is always returned by the function. */ -static struct pointer_set_t * +static hash_set * suggest_attribute (int option, tree decl, bool known_finite, - struct pointer_set_t *warned_about, + hash_set *warned_about, const char * attrib_name) { if (!option_enabled (option, &global_options)) @@ -149,10 +148,10 @@ suggest_attribute (int option, tree decl, bool known_finite, return warned_about; if (!warned_about) - warned_about = pointer_set_create (); - if (pointer_set_contains (warned_about, decl)) + warned_about = new hash_set; + if (warned_about->contains (decl)) return warned_about; - pointer_set_insert (warned_about, decl); + warned_about->add (decl); warning_at (DECL_SOURCE_LOCATION (decl), option, known_finite @@ -168,7 +167,7 @@ suggest_attribute (int option, tree decl, bool known_finite, static void warn_function_pure (tree decl, bool known_finite) { - static struct pointer_set_t *warned_about; + static hash_set *warned_about; warned_about = suggest_attribute (OPT_Wsuggest_attribute_pure, decl, @@ -181,7 +180,7 @@ warn_function_pure (tree decl, bool known_finite) static void warn_function_const (tree decl, bool known_finite) { - static struct pointer_set_t *warned_about; + static hash_set *warned_about; warned_about = suggest_attribute (OPT_Wsuggest_attribute_const, decl, known_finite, warned_about, "const"); @@ -190,7 +189,7 @@ warn_function_const (tree decl, bool known_finite) static void warn_function_noreturn (tree decl) { - static struct pointer_set_t *warned_about; + static hash_set *warned_about; if (!lang_hooks.missing_noreturn_ok_p (decl) && targetm.warn_func_return (decl)) warned_about @@ -846,11 +845,8 @@ add_new_function (struct cgraph_node *node, void *data ATTRIBUTE_UNUSED) static declarations. We do not need to scan them more than once since all we would be interested in are the addressof operations. */ - visited_nodes = pointer_set_create (); if (node->get_availability () > AVAIL_INTERPOSABLE) set_function_state (node, analyze_function (node, true)); - pointer_set_destroy (visited_nodes); - visited_nodes = NULL; } /* Called when new clone is inserted to callgraph late. */ @@ -912,12 +908,6 @@ pure_const_generate_summary (void) register_hooks (); - /* There are some shared nodes, in particular the initializers on - static declarations. We do not need to scan them more than once - since all we would be interested in are the addressof - operations. */ - visited_nodes = pointer_set_create (); - /* Process all of the functions. We process AVAIL_INTERPOSABLE functions. We can not use the results @@ -927,9 +917,6 @@ pure_const_generate_summary (void) FOR_EACH_DEFINED_FUNCTION (node) if (node->get_availability () >= AVAIL_INTERPOSABLE) set_function_state (node, analyze_function (node, true)); - - pointer_set_destroy (visited_nodes); - visited_nodes = NULL; } diff --git a/main/gcc/ipa-utils.c b/main/gcc/ipa-utils.c index 985260cdf6e..21d1fe621c2 100644 --- a/main/gcc/ipa-utils.c +++ b/main/gcc/ipa-utils.c @@ -385,264 +385,6 @@ get_base_var (tree t) } -/* Create a new cgraph node set. */ - -cgraph_node_set -cgraph_node_set_new (void) -{ - cgraph_node_set new_node_set; - - new_node_set = XCNEW (struct cgraph_node_set_def); - new_node_set->map = pointer_map_create (); - new_node_set->nodes.create (0); - return new_node_set; -} - - -/* Add cgraph_node NODE to cgraph_node_set SET. */ - -void -cgraph_node_set_add (cgraph_node_set set, struct cgraph_node *node) -{ - void **slot; - - slot = pointer_map_insert (set->map, node); - - if (*slot) - { - int index = (size_t) *slot - 1; - gcc_checking_assert ((set->nodes[index] - == node)); - return; - } - - *slot = (void *)(size_t) (set->nodes.length () + 1); - - /* Insert into node vector. */ - set->nodes.safe_push (node); -} - - -/* Remove cgraph_node NODE from cgraph_node_set SET. */ - -void -cgraph_node_set_remove (cgraph_node_set set, struct cgraph_node *node) -{ - void **slot, **last_slot; - int index; - struct cgraph_node *last_node; - - slot = pointer_map_contains (set->map, node); - if (slot == NULL || !*slot) - return; - - index = (size_t) *slot - 1; - gcc_checking_assert (set->nodes[index] - == node); - - /* Remove from vector. We do this by swapping node with the last element - of the vector. */ - last_node = set->nodes.pop (); - if (last_node != node) - { - last_slot = pointer_map_contains (set->map, last_node); - gcc_checking_assert (last_slot && *last_slot); - *last_slot = (void *)(size_t) (index + 1); - - /* Move the last element to the original spot of NODE. */ - set->nodes[index] = last_node; - } - - /* Remove element from hash table. */ - *slot = NULL; -} - - -/* Find NODE in SET and return an iterator to it if found. A null iterator - is returned if NODE is not in SET. */ - -cgraph_node_set_iterator -cgraph_node_set_find (cgraph_node_set set, struct cgraph_node *node) -{ - void **slot; - cgraph_node_set_iterator csi; - - slot = pointer_map_contains (set->map, node); - if (slot == NULL || !*slot) - csi.index = (unsigned) ~0; - else - csi.index = (size_t)*slot - 1; - csi.set = set; - - return csi; -} - - -/* Dump content of SET to file F. */ - -void -dump_cgraph_node_set (FILE *f, cgraph_node_set set) -{ - cgraph_node_set_iterator iter; - - for (iter = csi_start (set); !csi_end_p (iter); csi_next (&iter)) - { - struct cgraph_node *node = csi_node (iter); - fprintf (f, " %s/%i", node->name (), node->order); - } - fprintf (f, "\n"); -} - - -/* Dump content of SET to stderr. */ - -DEBUG_FUNCTION void -debug_cgraph_node_set (cgraph_node_set set) -{ - dump_cgraph_node_set (stderr, set); -} - - -/* Free varpool node set. */ - -void -free_cgraph_node_set (cgraph_node_set set) -{ - set->nodes.release (); - pointer_map_destroy (set->map); - free (set); -} - - -/* Create a new varpool node set. */ - -varpool_node_set -varpool_node_set_new (void) -{ - varpool_node_set new_node_set; - - new_node_set = XCNEW (struct varpool_node_set_def); - new_node_set->map = pointer_map_create (); - new_node_set->nodes.create (0); - return new_node_set; -} - - -/* Add varpool_node NODE to varpool_node_set SET. */ - -void -varpool_node_set_add (varpool_node_set set, varpool_node *node) -{ - void **slot; - - slot = pointer_map_insert (set->map, node); - - if (*slot) - { - int index = (size_t) *slot - 1; - gcc_checking_assert ((set->nodes[index] - == node)); - return; - } - - *slot = (void *)(size_t) (set->nodes.length () + 1); - - /* Insert into node vector. */ - set->nodes.safe_push (node); -} - - -/* Remove varpool_node NODE from varpool_node_set SET. */ - -void -varpool_node_set_remove (varpool_node_set set, varpool_node *node) -{ - void **slot, **last_slot; - int index; - varpool_node *last_node; - - slot = pointer_map_contains (set->map, node); - if (slot == NULL || !*slot) - return; - - index = (size_t) *slot - 1; - gcc_checking_assert (set->nodes[index] - == node); - - /* Remove from vector. We do this by swapping node with the last element - of the vector. */ - last_node = set->nodes.pop (); - if (last_node != node) - { - last_slot = pointer_map_contains (set->map, last_node); - gcc_checking_assert (last_slot && *last_slot); - *last_slot = (void *)(size_t) (index + 1); - - /* Move the last element to the original spot of NODE. */ - set->nodes[index] = last_node; - } - - /* Remove element from hash table. */ - *slot = NULL; -} - - -/* Find NODE in SET and return an iterator to it if found. A null iterator - is returned if NODE is not in SET. */ - -varpool_node_set_iterator -varpool_node_set_find (varpool_node_set set, varpool_node *node) -{ - void **slot; - varpool_node_set_iterator vsi; - - slot = pointer_map_contains (set->map, node); - if (slot == NULL || !*slot) - vsi.index = (unsigned) ~0; - else - vsi.index = (size_t)*slot - 1; - vsi.set = set; - - return vsi; -} - - -/* Dump content of SET to file F. */ - -void -dump_varpool_node_set (FILE *f, varpool_node_set set) -{ - varpool_node_set_iterator iter; - - for (iter = vsi_start (set); !vsi_end_p (iter); vsi_next (&iter)) - { - varpool_node *node = vsi_node (iter); - fprintf (f, " %s", node->name ()); - } - fprintf (f, "\n"); -} - - -/* Free varpool node set. */ - -void -free_varpool_node_set (varpool_node_set set) -{ - set->nodes.release (); - pointer_map_destroy (set->map); - free (set); -} - - -/* Dump content of SET to stderr. */ - -DEBUG_FUNCTION void -debug_varpool_node_set (varpool_node_set set) -{ - dump_varpool_node_set (stderr, set); -} - - /* SRC and DST are going to be merged. Take SRC's profile and merge it into DST so it is not going to be lost. Destroy SRC's body on the way. */ @@ -664,13 +406,8 @@ ipa_merge_profiles (struct cgraph_node *dst, if (dst->tp_first_run > src->tp_first_run && src->tp_first_run) dst->tp_first_run = src->tp_first_run; - if (src->profile_id) - { - if (!dst->profile_id) - dst->profile_id = src->profile_id; - else - gcc_assert (src->profile_id == dst->profile_id); - } + if (src->profile_id && !dst->profile_id) + dst->profile_id = src->profile_id; if (!dst->count) return; diff --git a/main/gcc/ipa-utils.h b/main/gcc/ipa-utils.h index bdddbdca0e8..c3a47a1e5f4 100644 --- a/main/gcc/ipa-utils.h +++ b/main/gcc/ipa-utils.h @@ -42,13 +42,19 @@ struct ipa_dfs_info { type inheritance graph. */ struct ipa_polymorphic_call_context { /* The called object appears in an object of type OUTER_TYPE - at offset OFFSET. */ + at offset OFFSET. When information is not 100% reliable, we + use SPECULATIVE_OUTER_TYPE and SPECULATIVE_OFFSET. */ HOST_WIDE_INT offset; + HOST_WIDE_INT speculative_offset; tree outer_type; + tree speculative_outer_type; /* True if outer object may be in construction or destruction. */ bool maybe_in_construction; /* True if outer object may be of derived type. */ bool maybe_derived_type; + /* True if speculative outer object may be of derived type. We always + speculate that construction does not happen. */ + bool speculative_maybe_derived_type; }; /* Context representing "I know nothing". */ @@ -93,6 +99,7 @@ tree get_polymorphic_call_info (tree, tree, tree *, HOST_WIDE_INT *, ipa_polymorphic_call_context *, gimple call = NULL); +bool get_dynamic_type (tree, ipa_polymorphic_call_context *, tree, gimple); bool get_polymorphic_call_info_from_invariant (ipa_polymorphic_call_context *, tree, tree, HOST_WIDE_INT); bool decl_maybe_in_construction_p (tree, tree, gimple, tree); @@ -118,9 +125,12 @@ possible_polymorphic_call_targets (struct cgraph_edge *e, { gcc_checking_assert (e->indirect_info->polymorphic); ipa_polymorphic_call_context context = {e->indirect_info->offset, + e->indirect_info->speculative_offset, e->indirect_info->outer_type, + e->indirect_info->speculative_outer_type, e->indirect_info->maybe_in_construction, - e->indirect_info->maybe_derived_type}; + e->indirect_info->maybe_derived_type, + e->indirect_info->speculative_maybe_derived_type}; return possible_polymorphic_call_targets (e->indirect_info->otr_type, e->indirect_info->otr_token, context, @@ -157,9 +167,12 @@ dump_possible_polymorphic_call_targets (FILE *f, struct cgraph_edge *e) { gcc_checking_assert (e->indirect_info->polymorphic); ipa_polymorphic_call_context context = {e->indirect_info->offset, + e->indirect_info->speculative_offset, e->indirect_info->outer_type, + e->indirect_info->speculative_outer_type, e->indirect_info->maybe_in_construction, - e->indirect_info->maybe_derived_type}; + e->indirect_info->maybe_derived_type, + e->indirect_info->speculative_maybe_derived_type}; dump_possible_polymorphic_call_targets (f, e->indirect_info->otr_type, e->indirect_info->otr_token, context); @@ -172,10 +185,11 @@ inline bool possible_polymorphic_call_target_p (struct cgraph_edge *e, struct cgraph_node *n) { - ipa_polymorphic_call_context context = {e->indirect_info->offset, - e->indirect_info->outer_type, + ipa_polymorphic_call_context context = {e->indirect_info->offset, 0, + e->indirect_info->outer_type, NULL, e->indirect_info->maybe_in_construction, - e->indirect_info->maybe_derived_type}; + e->indirect_info->maybe_derived_type, + false}; return possible_polymorphic_call_target_p (e->indirect_info->otr_type, e->indirect_info->otr_token, context, n); diff --git a/main/gcc/ipa-visibility.c b/main/gcc/ipa-visibility.c index 1cd4d3c2fa0..eda3f2a7ea1 100644 --- a/main/gcc/ipa-visibility.c +++ b/main/gcc/ipa-visibility.c @@ -691,12 +691,11 @@ function_and_variable_visibility (bool whole_program) } if (found) { - struct pointer_set_t *visited_nodes = pointer_set_create (); + hash_set visited_nodes; vnode->get_constructor (); walk_tree (&DECL_INITIAL (vnode->decl), - update_vtable_references, NULL, visited_nodes); - pointer_set_destroy (visited_nodes); + update_vtable_references, NULL, &visited_nodes); vnode->remove_all_references (); record_references_in_initializer (vnode->decl, false); } diff --git a/main/gcc/ipa.c b/main/gcc/ipa.c index 49476f036ed..806bd862ce0 100644 --- a/main/gcc/ipa.c +++ b/main/gcc/ipa.c @@ -28,7 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "toplev.h" #include "tree-pass.h" #include "hash-map.h" -#include "pointer-set.h" +#include "hash-set.h" #include "gimple-expr.h" #include "gimplify.h" #include "flags.h" @@ -86,14 +86,14 @@ update_inlined_to_pointer (struct cgraph_node *node, struct cgraph_node *inlined static void enqueue_node (symtab_node *node, symtab_node **first, - struct pointer_set_t *reachable) + hash_set *reachable) { /* Node is still in queue; do nothing. */ if (node->aux && node->aux != (void *) 2) return; /* Node was already processed as unreachable, re-enqueue only if it became reachable now. */ - if (node->aux == (void *)2 && !pointer_set_contains (reachable, node)) + if (node->aux == (void *)2 && !reachable->contains (node)) return; node->aux = *first; *first = node; @@ -105,7 +105,7 @@ static void process_references (symtab_node *snode, symtab_node **first, bool before_inlining_p, - struct pointer_set_t *reachable) + hash_set *reachable) { int i; struct ipa_ref *ref = NULL; @@ -129,13 +129,13 @@ process_references (symtab_node *snode, && flag_wpa && ctor_for_folding (node->decl) != error_mark_node)))) - pointer_set_insert (reachable, node); + reachable->add (node); else if (L_IPO_COMP_MODE && cgraph_pre_profiling_inlining_done && is_a (node) && ctor_for_folding (real_varpool_node (node->decl)->decl) != error_mark_node) - pointer_set_insert (reachable, node); + reachable->add (node); enqueue_node (node, first, reachable); } @@ -150,10 +150,11 @@ process_references (symtab_node *snode, possible. */ static void -walk_polymorphic_call_targets (pointer_set_t *reachable_call_targets, +walk_polymorphic_call_targets (hash_set *reachable_call_targets, struct cgraph_edge *edge, symtab_node **first, - pointer_set_t *reachable, bool before_inlining_p) + hash_set *reachable, + bool before_inlining_p) { unsigned int i; void *cache_token; @@ -162,8 +163,7 @@ walk_polymorphic_call_targets (pointer_set_t *reachable_call_targets, = possible_polymorphic_call_targets (edge, &final, &cache_token); - if (!pointer_set_insert (reachable_call_targets, - cache_token)) + if (!reachable_call_targets->add (cache_token)) { for (i = 0; i < targets.length (); i++) { @@ -184,7 +184,7 @@ walk_polymorphic_call_targets (pointer_set_t *reachable_call_targets, && (cgraph_state < CGRAPH_STATE_IPA_SSA || !lookup_attribute ("always_inline", DECL_ATTRIBUTES (n->decl))))) - pointer_set_insert (reachable, n); + reachable->add (n); /* Even after inlining we want to keep the possible targets in the boundary, so late passes can still produce direct call even if @@ -288,9 +288,9 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) struct cgraph_node *node, *next; varpool_node *vnode, *vnext; bool changed = false; - struct pointer_set_t *reachable = pointer_set_create (); - struct pointer_set_t *body_needed_for_clonning = pointer_set_create (); - struct pointer_set_t *reachable_call_targets = pointer_set_create (); + hash_set reachable; + hash_set body_needed_for_clonning; + hash_set reachable_call_targets; /* In LIPO mode, do not remove functions until after global linking is performed. Otherwise functions needed for cross module inlining @@ -324,8 +324,8 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) && !node->can_remove_if_no_direct_calls_and_refs_p ()) { gcc_assert (!node->global.inlined_to); - pointer_set_insert (reachable, node); - enqueue_node (node, &first, reachable); + reachable.add (node); + enqueue_node (node, &first, &reachable); } else gcc_assert (!node->aux); @@ -336,14 +336,14 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) if (!vnode->can_remove_if_no_refs_p() && !vnode->in_other_partition) { - pointer_set_insert (reachable, vnode); - enqueue_node (vnode, &first, reachable); + reachable.add (vnode); + enqueue_node (vnode, &first, &reachable); } /* Perform reachability analysis. */ while (first != (symtab_node *) (void *) 1) { - bool in_boundary_p = !pointer_set_contains (reachable, first); + bool in_boundary_p = !reachable.contains (first); symtab_node *node = first; first = (symtab_node *)first->aux; @@ -360,7 +360,7 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) struct cgraph_node *origin_node = cgraph_node::get_create (DECL_ABSTRACT_ORIGIN (node->decl)); origin_node->used_as_abstract_origin = true; - enqueue_node (origin_node, &first, reachable); + enqueue_node (origin_node, &first, &reachable); } /* If any symbol in a comdat group is reachable, force all externally visible symbols in the same comdat @@ -373,11 +373,11 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) next != node; next = next->same_comdat_group) if (!next->comdat_local_p () - && !pointer_set_insert (reachable, next)) - enqueue_node (next, &first, reachable); + && !reachable.add (next)) + enqueue_node (next, &first, &reachable); } /* Mark references as reachable. */ - process_references (node, &first, before_inlining_p, reachable); + process_references (node, &first, before_inlining_p, &reachable); } if (cgraph_node *cnode = dyn_cast (node)) @@ -395,8 +395,8 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) { next = e->next_callee; if (e->indirect_info->polymorphic) - walk_polymorphic_call_targets (reachable_call_targets, - e, &first, reachable, + walk_polymorphic_call_targets (&reachable_call_targets, + e, &first, &reachable, before_inlining_p); } } @@ -415,17 +415,16 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) if (DECL_EXTERNAL (e->callee->decl) && e->callee->alias && before_inlining_p) - pointer_set_insert (reachable, - e->callee->function_symbol ()); - pointer_set_insert (reachable, e->callee); + reachable.add (e->callee->function_symbol ()); + reachable.add (e->callee); } - enqueue_node (e->callee, &first, reachable); + enqueue_node (e->callee, &first, &reachable); } /* When inline clone exists, mark body to be preserved so when removing offline copy of the function we don't kill it. */ if (cnode->global.inlined_to) - pointer_set_insert (body_needed_for_clonning, cnode->decl); + body_needed_for_clonning.add (cnode->decl); /* For non-inline clones, force their origins to the boundary and ensure that body is not removed. */ @@ -435,8 +434,8 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) cnode = cnode->clone_of; if (noninline) { - pointer_set_insert (body_needed_for_clonning, cnode->decl); - enqueue_node (cnode, &first, reachable); + body_needed_for_clonning.add (cnode->decl); + enqueue_node (cnode, &first, &reachable); } } @@ -450,8 +449,8 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) next; next = next->simdclone->next_clone) if (in_boundary_p - || !pointer_set_insert (reachable, next)) - enqueue_node (next, &first, reachable); + || !reachable.add (next)) + enqueue_node (next, &first, &reachable); } } /* When we see constructor of external variable, keep referred nodes in the @@ -465,7 +464,7 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) { struct ipa_ref *ref = NULL; for (int i = 0; node->iterate_reference (i, ref); i++) - enqueue_node (ref->referred, &first, reachable); + enqueue_node (ref->referred, &first, &reachable); } } @@ -483,9 +482,9 @@ symtab_remove_unreachable_nodes (bool before_inlining_p, FILE *file) changed = true; } /* If node is unreachable, remove its body. */ - else if (!pointer_set_contains (reachable, node)) + else if (!reachable.contains (node)) { - if (!pointer_set_contains (body_needed_for_clonning, node->decl)) + if (!body_needed_for_clonning.contains (node->decl)) node->release_body (); else if (!node->clone_of) gcc_assert (in_lto_p || DECL_RESULT (node->decl)); @@ -573,7 +572,7 @@ error " Check the following code " vnode->remove (); changed = true; } - else if (!pointer_set_contains (reachable, vnode)) + else if (!reachable.contains (vnode)) { tree init; if (vnode->definition) @@ -600,10 +599,6 @@ error " Check the following code " vnode->aux = NULL; } - pointer_set_destroy (reachable); - pointer_set_destroy (body_needed_for_clonning); - pointer_set_destroy (reachable_call_targets); - /* Now update address_taken flags and try to promote functions to be local. */ if (file) fprintf (file, "\nClearing address taken flags:"); diff --git a/main/gcc/ira-costs.c b/main/gcc/ira-costs.c index a83e1dff00c..13bbf077829 100644 --- a/main/gcc/ira-costs.c +++ b/main/gcc/ira-costs.c @@ -1753,6 +1753,20 @@ find_costs_and_classes (FILE *dump_file) alt_class = ira_allocno_class_translate[alt_class]; if (best_cost > i_mem_cost) regno_aclass[i] = NO_REGS; + else if (!optimize && !targetm.class_likely_spilled_p (best)) + /* Registers in the alternative class are likely to need + longer or slower sequences than registers in the best class. + When optimizing we make some effort to use the best class + over the alternative class where possible, but at -O0 we + effectively give the alternative class equal weight. + We then run the risk of using slower alternative registers + when plenty of registers from the best class are still free. + This is especially true because live ranges tend to be very + short in -O0 code and so register pressure tends to be low. + + Avoid that by ignoring the alternative class if the best + class has plenty of registers. */ + regno_aclass[i] = best; else { /* Make the common class the biggest class of best and diff --git a/main/gcc/ira.c b/main/gcc/ira.c index 1dd21871865..ccc6c798862 100644 --- a/main/gcc/ira.c +++ b/main/gcc/ira.c @@ -2221,25 +2221,6 @@ ira_bad_reload_regno (int regno, rtx in, rtx out) || ira_bad_reload_regno_1 (regno, out)); } -/* Return TRUE if *LOC contains an asm. */ -static int -insn_contains_asm_1 (rtx *loc, void *data ATTRIBUTE_UNUSED) -{ - if ( !*loc) - return FALSE; - if (GET_CODE (*loc) == ASM_OPERANDS) - return TRUE; - return FALSE; -} - - -/* Return TRUE if INSN contains an ASM. */ -static bool -insn_contains_asm (rtx insn) -{ - return for_each_rtx (&insn, insn_contains_asm_1, NULL); -} - /* Add register clobbers from asm statements. */ static void compute_regs_asm_clobbered (void) @@ -2253,7 +2234,7 @@ compute_regs_asm_clobbered (void) { df_ref def; - if (insn_contains_asm (insn)) + if (NONDEBUG_INSN_P (insn) && extract_asm_operands (PATTERN (insn))) FOR_EACH_INSN_DEF (def, insn) { unsigned int dregno = DF_REF_REGNO (def); diff --git a/main/gcc/langhooks.c b/main/gcc/langhooks.c index 0c045de41cf..0dfca206568 100644 --- a/main/gcc/langhooks.c +++ b/main/gcc/langhooks.c @@ -709,14 +709,13 @@ lhd_begin_section (const char *name) /* Write DATA of length LEN to the current LTO output section. This default - implementation just calls assemble_string and frees BLOCK. */ + implementation just calls assemble_string. */ void -lhd_append_data (const void *data, size_t len, void *block) +lhd_append_data (const void *data, size_t len, void *) { if (data) assemble_string ((const char *)data, len); - free (block); } diff --git a/main/gcc/lto-cgraph.c b/main/gcc/lto-cgraph.c index b1fcf67a025..12b649a7ded 100644 --- a/main/gcc/lto-cgraph.c +++ b/main/gcc/lto-cgraph.c @@ -37,6 +37,7 @@ along with GCC; see the file COPYING3. If not see #include "params.h" #include "input.h" #include "hashtab.h" +#include "hash-set.h" #include "langhooks.h" #include "bitmap.h" #include "function.h" @@ -92,7 +93,7 @@ lto_symtab_encoder_new (bool for_input) lto_symtab_encoder_t encoder = XCNEW (struct lto_symtab_encoder_d); if (!for_input) - encoder->map = pointer_map_create (); + encoder->map = new hash_map; encoder->nodes.create (0); return encoder; } @@ -105,7 +106,7 @@ lto_symtab_encoder_delete (lto_symtab_encoder_t encoder) { encoder->nodes.release (); if (encoder->map) - pointer_map_destroy (encoder->map); + delete encoder->map; free (encoder); } @@ -119,7 +120,6 @@ lto_symtab_encoder_encode (lto_symtab_encoder_t encoder, symtab_node *node) { int ref; - void **slot; if (!encoder->map) { @@ -130,18 +130,17 @@ lto_symtab_encoder_encode (lto_symtab_encoder_t encoder, return ref; } - slot = pointer_map_contains (encoder->map, node); + size_t *slot = encoder->map->get (node); if (!slot || !*slot) { lto_encoder_entry entry = {node, false, false, false}; ref = encoder->nodes.length (); if (!slot) - slot = pointer_map_insert (encoder->map, node); - *slot = (void *) (intptr_t) (ref + 1); + encoder->map->put (node, ref + 1); encoder->nodes.safe_push (entry); } else - ref = (size_t) *slot - 1; + ref = *slot - 1; return ref; } @@ -152,15 +151,14 @@ bool lto_symtab_encoder_delete_node (lto_symtab_encoder_t encoder, symtab_node *node) { - void **slot, **last_slot; int index; lto_encoder_entry last_node; - slot = pointer_map_contains (encoder->map, node); + size_t *slot = encoder->map->get (node); if (slot == NULL || !*slot) return false; - index = (size_t) *slot - 1; + index = *slot - 1; gcc_checking_assert (encoder->nodes[index].node == node); /* Remove from vector. We do this by swapping node with the last element @@ -168,16 +166,14 @@ lto_symtab_encoder_delete_node (lto_symtab_encoder_t encoder, last_node = encoder->nodes.pop (); if (last_node.node != node) { - last_slot = pointer_map_contains (encoder->map, last_node.node); - gcc_checking_assert (last_slot && *last_slot); - *last_slot = (void *)(size_t) (index + 1); + gcc_assert (encoder->map->put (last_node.node, index + 1)); /* Move the last element to the original spot of NODE. */ encoder->nodes[index] = last_node; } /* Remove element from hash table. */ - *slot = NULL; + encoder->map->remove (node); return true; } @@ -488,7 +484,7 @@ lto_output_node (struct lto_simple_output_block *ob, struct cgraph_node *node, comdat = IDENTIFIER_POINTER (group); else comdat = ""; - lto_output_data_stream (ob->main_stream, comdat, strlen (comdat) + 1); + streamer_write_data_stream (ob->main_stream, comdat, strlen (comdat) + 1); if (group) { @@ -546,7 +542,7 @@ lto_output_node (struct lto_simple_output_block *ob, struct cgraph_node *node, bp_pack_enum (&bp, ld_plugin_symbol_resolution, LDPR_NUM_KNOWN, node->resolution); streamer_write_bitpack (&bp); - lto_output_data_stream (ob->main_stream, section, strlen (section) + 1); + streamer_write_data_stream (ob->main_stream, section, strlen (section) + 1); if (node->thunk.thunk_p && !boundary_p) { @@ -622,7 +618,7 @@ lto_output_varpool_node (struct lto_simple_output_block *ob, varpool_node *node, comdat = IDENTIFIER_POINTER (group); else comdat = ""; - lto_output_data_stream (ob->main_stream, comdat, strlen (comdat) + 1); + streamer_write_data_stream (ob->main_stream, comdat, strlen (comdat) + 1); if (group) { @@ -640,7 +636,7 @@ lto_output_varpool_node (struct lto_simple_output_block *ob, varpool_node *node, section = node->get_section (); if (!section) section = ""; - lto_output_data_stream (ob->main_stream, section, strlen (section) + 1); + streamer_write_data_stream (ob->main_stream, section, strlen (section) + 1); streamer_write_enum (ob->main_stream, ld_plugin_symbol_resolution, LDPR_NUM_KNOWN, node->resolution); @@ -819,7 +815,7 @@ compute_ltrans_boundary (lto_symtab_encoder_t in_encoder) int i; lto_symtab_encoder_t encoder; lto_symtab_encoder_iterator lsei; - struct pointer_set_t *reachable_call_targets = pointer_set_create (); + hash_set reachable_call_targets; encoder = lto_symtab_encoder_new (false); @@ -902,8 +898,7 @@ compute_ltrans_boundary (lto_symtab_encoder_t in_encoder) vec targets = possible_polymorphic_call_targets (edge, &final, &cache_token); - if (!pointer_set_insert (reachable_call_targets, - cache_token)) + if (!reachable_call_targets.add (cache_token)) { for (i = 0; i < targets.length (); i++) { @@ -923,7 +918,6 @@ compute_ltrans_boundary (lto_symtab_encoder_t in_encoder) } } lto_symtab_encoder_delete (in_encoder); - pointer_set_destroy (reachable_call_targets); return encoder; } diff --git a/main/gcc/lto-opts.c b/main/gcc/lto-opts.c index 06796d62a3e..986fb971071 100644 --- a/main/gcc/lto-opts.c +++ b/main/gcc/lto-opts.c @@ -67,7 +67,6 @@ append_to_collect_gcc_options (struct obstack *ob, void lto_write_options (void) { - struct lto_output_stream stream; char *section_name; struct obstack temporary_obstack; unsigned int i, j; @@ -76,7 +75,6 @@ lto_write_options (void) section_name = lto_get_section_name (LTO_section_opts, NULL, NULL); lto_begin_section (section_name, false); - memset (&stream, 0, sizeof (stream)); obstack_init (&temporary_obstack); @@ -170,9 +168,7 @@ lto_write_options (void) } obstack_grow (&temporary_obstack, "\0", 1); args = XOBFINISH (&temporary_obstack, char *); - lto_output_data_stream (&stream, args, strlen (args) + 1); - - lto_write_stream (&stream); + lto_write_data (args, strlen (args) + 1); lto_end_section (); obstack_free (&temporary_obstack, NULL); diff --git a/main/gcc/lto-section-out.c b/main/gcc/lto-section-out.c index 00b18016a83..0c5f792bcde 100644 --- a/main/gcc/lto-section-out.c +++ b/main/gcc/lto-section-out.c @@ -98,6 +98,16 @@ lto_end_section (void) lang_hooks.lto.end_section (); } +/* Write SIZE bytes starting at DATA to the assembler. */ + +void +lto_write_data (const void *data, unsigned int size) +{ + if (compression_stream) + lto_compress_block (compression_stream, (const char *)data, size); + else + lang_hooks.lto.append_data ((const char *)data, size, NULL); +} /* Write all of the chars in OBS to the assembler. Recycle the blocks in obs as this is being done. */ @@ -128,90 +138,15 @@ lto_write_stream (struct lto_output_stream *obs) blocks up output differently to the way it's blocked here. So for now, we don't compress WPA output. */ if (compression_stream) - { - lto_compress_block (compression_stream, base, num_chars); - lang_hooks.lto.append_data (NULL, 0, block); - } + lto_compress_block (compression_stream, base, num_chars); else lang_hooks.lto.append_data (base, num_chars, block); + free (block); block_size *= 2; } } -/* Adds a new block to output stream OBS. */ - -void -lto_append_block (struct lto_output_stream *obs) -{ - struct lto_char_ptr_base *new_block; - - gcc_assert (obs->left_in_block == 0); - - if (obs->first_block == NULL) - { - /* This is the first time the stream has been written - into. */ - obs->block_size = 1024; - new_block = (struct lto_char_ptr_base*) xmalloc (obs->block_size); - obs->first_block = new_block; - } - else - { - struct lto_char_ptr_base *tptr; - /* Get a new block that is twice as big as the last block - and link it into the list. */ - obs->block_size *= 2; - new_block = (struct lto_char_ptr_base*) xmalloc (obs->block_size); - /* The first bytes of the block are reserved as a pointer to - the next block. Set the chain of the full block to the - pointer to the new block. */ - tptr = obs->current_block; - tptr->ptr = (char *) new_block; - } - - /* Set the place for the next char at the first position after the - chain to the next block. */ - obs->current_pointer - = ((char *) new_block) + sizeof (struct lto_char_ptr_base); - obs->current_block = new_block; - /* Null out the newly allocated block's pointer to the next block. */ - new_block->ptr = NULL; - obs->left_in_block = obs->block_size - sizeof (struct lto_char_ptr_base); -} - - -/* Write raw DATA of length LEN to the output block OB. */ - -void -lto_output_data_stream (struct lto_output_stream *obs, const void *data, - size_t len) -{ - while (len) - { - size_t copy; - - /* No space left. */ - if (obs->left_in_block == 0) - lto_append_block (obs); - - /* Determine how many bytes to copy in this loop. */ - if (len <= obs->left_in_block) - copy = len; - else - copy = obs->left_in_block; - - /* Copy the data and do bookkeeping. */ - memcpy (obs->current_pointer, data, copy); - obs->current_pointer += copy; - obs->total_size += copy; - obs->left_in_block -= copy; - data = (const char *) data + copy; - len -= copy; - } -} - - /* Lookup NAME in ENCODER. If NAME is not found, create a new entry in ENCODER for NAME with the next available index of ENCODER, then print the index to OBS. True is returned if NAME was added to @@ -335,7 +270,6 @@ lto_destroy_simple_output_block (struct lto_simple_output_block *ob) { char *section_name; struct lto_simple_header header; - struct lto_output_stream *header_stream; section_name = lto_get_section_name (ob->section_type, NULL, NULL); lto_begin_section (section_name, !flag_wpa); @@ -346,15 +280,9 @@ lto_destroy_simple_output_block (struct lto_simple_output_block *ob) memset (&header, 0, sizeof (struct lto_simple_header)); header.lto_header.major_version = LTO_major_version; header.lto_header.minor_version = LTO_minor_version; - header.compressed_size = 0; - header.main_size = ob->main_stream->total_size; - - header_stream = XCNEW (struct lto_output_stream); - lto_output_data_stream (header_stream, &header, sizeof header); - lto_write_stream (header_stream); - free (header_stream); + lto_write_data (&header, sizeof header); lto_write_stream (ob->main_stream); diff --git a/main/gcc/lto-streamer-in.c b/main/gcc/lto-streamer-in.c index 3ece457c15b..698f92620db 100644 --- a/main/gcc/lto-streamer-in.c +++ b/main/gcc/lto-streamer-in.c @@ -1427,6 +1427,5 @@ lto_data_in_delete (struct data_in *data_in) { data_in->globals_resolution.release (); streamer_tree_cache_delete (data_in->reader_cache); - free (data_in->labels); free (data_in); } diff --git a/main/gcc/lto-streamer-out.c b/main/gcc/lto-streamer-out.c index 355ceeaaf08..81a7b233932 100644 --- a/main/gcc/lto-streamer-out.c +++ b/main/gcc/lto-streamer-out.c @@ -32,6 +32,7 @@ along with GCC; see the file COPYING3. If not see #include "params.h" #include "input.h" #include "hashtab.h" +#include "hash-set.h" #include "basic-block.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -44,6 +45,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-pass.h" #include "function.h" #include "diagnostic-core.h" +#include "inchash.h" #include "except.h" #include "lto-symtab.h" #include "lto-streamer.h" @@ -439,36 +441,71 @@ lto_output_tree_1 (struct output_block *ob, tree expr, hashval_t hash, } } -struct sccs +class DFS { - unsigned int dfsnum; - unsigned int low; +public: + DFS (struct output_block *ob, tree expr, bool ref_p, bool this_ref_p, + bool single_p); + ~DFS (); + + struct scc_entry + { + tree t; + hashval_t hash; + }; + vec sccstack; + +private: + struct sccs + { + unsigned int dfsnum; + unsigned int low; + }; + + static int scc_entry_compare (const void *, const void *); + + void DFS_write_tree_body (struct output_block *ob, + tree expr, sccs *expr_state, bool ref_p, + bool single_p); + + void DFS_write_tree (struct output_block *ob, sccs *from_state, + tree expr, bool ref_p, bool this_ref_p, + bool single_p); + hashval_t + hash_scc (struct output_block *ob, unsigned first, unsigned size); + + unsigned int next_dfs_num; + struct pointer_map_t *sccstate; + struct obstack sccstate_obstack; }; -struct scc_entry +DFS::DFS (struct output_block *ob, tree expr, bool ref_p, bool this_ref_p, + bool single_p) { - tree t; - hashval_t hash; -}; - -static unsigned int next_dfs_num; -static vec sccstack; -static struct pointer_map_t *sccstate; -static struct obstack sccstate_obstack; + sccstack.create (0); + sccstate = pointer_map_create (); + gcc_obstack_init (&sccstate_obstack); + next_dfs_num = 1; + DFS_write_tree (ob, NULL, expr, ref_p, this_ref_p, single_p); +} -static void -DFS_write_tree (struct output_block *ob, sccs *from_state, - tree expr, bool ref_p, bool this_ref_p); +DFS::~DFS () +{ + sccstack.release (); + pointer_map_destroy (sccstate); + obstack_free (&sccstate_obstack, NULL); +} /* Handle the tree EXPR in the DFS walk with SCC state EXPR_STATE and DFS recurse for all tree edges originating from it. */ -static void -DFS_write_tree_body (struct output_block *ob, - tree expr, sccs *expr_state, bool ref_p) +void +DFS::DFS_write_tree_body (struct output_block *ob, + tree expr, sccs *expr_state, bool ref_p, + bool single_p) { #define DFS_follow_tree_edge(DEST) \ - DFS_write_tree (ob, expr_state, DEST, ref_p, ref_p) + DFS_write_tree (ob, expr_state, DEST, ref_p, ref_p, single_p) enum tree_code code; @@ -689,232 +726,230 @@ DFS_write_tree_body (struct output_block *ob, #undef DFS_follow_tree_edge } -/* Return a hash value for the tree T. */ +/* Return a hash value for the tree T. + CACHE holds hash values of trees outside current SCC. MAP, if non-NULL, + may hold hash values if trees inside current SCC. */ static hashval_t -hash_tree (struct streamer_tree_cache_d *cache, tree t) +hash_tree (struct streamer_tree_cache_d *cache, hash_map *map, tree t) { + inchash::hash hstate; + #define visit(SIBLING) \ do { \ unsigned ix; \ - if (SIBLING && streamer_tree_cache_lookup (cache, SIBLING, &ix)) \ - v = iterative_hash_hashval_t (streamer_tree_cache_get_hash (cache, ix), v); \ + if (!SIBLING) \ + hstate.add_int (0); \ + else if (streamer_tree_cache_lookup (cache, SIBLING, &ix)) \ + hstate.add_int (streamer_tree_cache_get_hash (cache, ix)); \ + else if (map) \ + hstate.add_int (*map->get (SIBLING)); \ + else \ + hstate.add_int (1); \ } while (0) /* Hash TS_BASE. */ enum tree_code code = TREE_CODE (t); - hashval_t v = iterative_hash_host_wide_int (code, 0); + hstate.add_int (code); if (!TYPE_P (t)) { - v = iterative_hash_host_wide_int (TREE_SIDE_EFFECTS (t) - | (TREE_CONSTANT (t) << 1) - | (TREE_READONLY (t) << 2) - | (TREE_PUBLIC (t) << 3), v); + hstate.add_flag (TREE_SIDE_EFFECTS (t)); + hstate.add_flag (TREE_CONSTANT (t)); + hstate.add_flag (TREE_READONLY (t)); + hstate.add_flag (TREE_PUBLIC (t)); } - v = iterative_hash_host_wide_int (TREE_ADDRESSABLE (t) - | (TREE_THIS_VOLATILE (t) << 1), v); + hstate.add_flag (TREE_ADDRESSABLE (t)); + hstate.add_flag (TREE_THIS_VOLATILE (t)); if (DECL_P (t)) - v = iterative_hash_host_wide_int (DECL_UNSIGNED (t), v); + hstate.add_flag (DECL_UNSIGNED (t)); else if (TYPE_P (t)) - v = iterative_hash_host_wide_int (TYPE_UNSIGNED (t), v); + hstate.add_flag (TYPE_UNSIGNED (t)); if (TYPE_P (t)) - v = iterative_hash_host_wide_int (TYPE_ARTIFICIAL (t), v); + hstate.add_flag (TYPE_ARTIFICIAL (t)); else - v = iterative_hash_host_wide_int (TREE_NO_WARNING (t), v); - v = iterative_hash_host_wide_int (TREE_NOTHROW (t) - | (TREE_STATIC (t) << 1) - | (TREE_PROTECTED (t) << 2) - | (TREE_DEPRECATED (t) << 3), v); + hstate.add_flag (TREE_NO_WARNING (t)); + hstate.add_flag (TREE_NOTHROW (t)); + hstate.add_flag (TREE_STATIC (t)); + hstate.add_flag (TREE_PROTECTED (t)); + hstate.add_flag (TREE_DEPRECATED (t)); if (code != TREE_BINFO) - v = iterative_hash_host_wide_int (TREE_PRIVATE (t), v); + hstate.add_flag (TREE_PRIVATE (t)); if (TYPE_P (t)) - v = iterative_hash_host_wide_int (TYPE_SATURATING (t) - | (TYPE_ADDR_SPACE (t) << 1), v); + { + hstate.add_flag (TYPE_SATURATING (t)); + hstate.add_flag (TYPE_ADDR_SPACE (t)); + } else if (code == SSA_NAME) - v = iterative_hash_host_wide_int (SSA_NAME_IS_DEFAULT_DEF (t), v); + hstate.add_flag (SSA_NAME_IS_DEFAULT_DEF (t)); + hstate.commit_flag (); if (CODE_CONTAINS_STRUCT (code, TS_INT_CST)) { int i; - v = iterative_hash_host_wide_int (TREE_INT_CST_NUNITS (t), v); - v = iterative_hash_host_wide_int (TREE_INT_CST_EXT_NUNITS (t), v); + hstate.add_wide_int (TREE_INT_CST_NUNITS (t)); + hstate.add_wide_int (TREE_INT_CST_EXT_NUNITS (t)); for (i = 0; i < TREE_INT_CST_NUNITS (t); i++) - v = iterative_hash_host_wide_int (TREE_INT_CST_ELT (t, i), v); + hstate.add_wide_int (TREE_INT_CST_ELT (t, i)); } if (CODE_CONTAINS_STRUCT (code, TS_REAL_CST)) { REAL_VALUE_TYPE r = TREE_REAL_CST (t); - v = iterative_hash_host_wide_int (r.cl, v); - v = iterative_hash_host_wide_int (r.decimal - | (r.sign << 1) - | (r.signalling << 2) - | (r.canonical << 3), v); - v = iterative_hash_host_wide_int (r.uexp, v); - for (unsigned i = 0; i < SIGSZ; ++i) - v = iterative_hash_host_wide_int (r.sig[i], v); + hstate.add_flag (r.cl); + hstate.add_flag (r.sign); + hstate.add_flag (r.signalling); + hstate.add_flag (r.canonical); + hstate.commit_flag (); + hstate.add_int (r.uexp); + hstate.add (r.sig, sizeof (r.sig)); } if (CODE_CONTAINS_STRUCT (code, TS_FIXED_CST)) { FIXED_VALUE_TYPE f = TREE_FIXED_CST (t); - v = iterative_hash_host_wide_int (f.mode, v); - v = iterative_hash_host_wide_int (f.data.low, v); - v = iterative_hash_host_wide_int (f.data.high, v); + hstate.add_int (f.mode); + hstate.add_int (f.data.low); + hstate.add_int (f.data.high); } if (CODE_CONTAINS_STRUCT (code, TS_DECL_COMMON)) { - v = iterative_hash_host_wide_int (DECL_MODE (t), v); - v = iterative_hash_host_wide_int (DECL_NONLOCAL (t) - | (DECL_VIRTUAL_P (t) << 1) - | (DECL_IGNORED_P (t) << 2) - | (DECL_ABSTRACT (t) << 3) - | (DECL_ARTIFICIAL (t) << 4) - | (DECL_USER_ALIGN (t) << 5) - | (DECL_PRESERVE_P (t) << 6) - | (DECL_EXTERNAL (t) << 7) - | (DECL_GIMPLE_REG_P (t) << 8), v); - v = iterative_hash_host_wide_int (DECL_ALIGN (t), v); + hstate.add_wide_int (DECL_MODE (t)); + hstate.add_flag (DECL_NONLOCAL (t)); + hstate.add_flag (DECL_VIRTUAL_P (t)); + hstate.add_flag (DECL_IGNORED_P (t)); + hstate.add_flag (DECL_ABSTRACT (t)); + hstate.add_flag (DECL_ARTIFICIAL (t)); + hstate.add_flag (DECL_USER_ALIGN (t)); + hstate.add_flag (DECL_PRESERVE_P (t)); + hstate.add_flag (DECL_EXTERNAL (t)); + hstate.add_flag (DECL_GIMPLE_REG_P (t)); + hstate.commit_flag (); + hstate.add_int (DECL_ALIGN (t)); if (code == LABEL_DECL) { - v = iterative_hash_host_wide_int (EH_LANDING_PAD_NR (t), v); - v = iterative_hash_host_wide_int (LABEL_DECL_UID (t), v); + hstate.add_int (EH_LANDING_PAD_NR (t)); + hstate.add_int (LABEL_DECL_UID (t)); } else if (code == FIELD_DECL) { - v = iterative_hash_host_wide_int (DECL_PACKED (t) - | (DECL_NONADDRESSABLE_P (t) << 1), - v); - v = iterative_hash_host_wide_int (DECL_OFFSET_ALIGN (t), v); + hstate.add_flag (DECL_PACKED (t)); + hstate.add_flag (DECL_NONADDRESSABLE_P (t)); + hstate.add_int (DECL_OFFSET_ALIGN (t)); } else if (code == VAR_DECL) { - v = iterative_hash_host_wide_int (DECL_HAS_DEBUG_EXPR_P (t) - | (DECL_NONLOCAL_FRAME (t) << 1), - v); + hstate.add_flag (DECL_HAS_DEBUG_EXPR_P (t)); + hstate.add_flag (DECL_NONLOCAL_FRAME (t)); } if (code == RESULT_DECL || code == PARM_DECL || code == VAR_DECL) { - v = iterative_hash_host_wide_int (DECL_BY_REFERENCE (t), v); + hstate.add_flag (DECL_BY_REFERENCE (t)); if (code == VAR_DECL || code == PARM_DECL) - v = iterative_hash_host_wide_int (DECL_HAS_VALUE_EXPR_P (t), v); + hstate.add_flag (DECL_HAS_VALUE_EXPR_P (t)); } + hstate.commit_flag (); } if (CODE_CONTAINS_STRUCT (code, TS_DECL_WRTL)) - v = iterative_hash_host_wide_int (DECL_REGISTER (t), v); + hstate.add_int (DECL_REGISTER (t)); if (CODE_CONTAINS_STRUCT (code, TS_DECL_WITH_VIS)) { - v = iterative_hash_host_wide_int ((DECL_COMMON (t)) - | (DECL_DLLIMPORT_P (t) << 1) - | (DECL_WEAK (t) << 2) - | (DECL_SEEN_IN_BIND_EXPR_P (t) << 3) - | (DECL_COMDAT (t) << 4) - | (DECL_VISIBILITY_SPECIFIED (t) << 6), - v); - v = iterative_hash_host_wide_int (DECL_VISIBILITY (t), v); + hstate.add_flag (DECL_COMMON (t)); + hstate.add_flag (DECL_DLLIMPORT_P (t)); + hstate.add_flag (DECL_WEAK (t)); + hstate.add_flag (DECL_SEEN_IN_BIND_EXPR_P (t)); + hstate.add_flag (DECL_COMDAT (t)); + hstate.add_flag (DECL_VISIBILITY_SPECIFIED (t)); + hstate.add_int (DECL_VISIBILITY (t)); if (code == VAR_DECL) { /* DECL_IN_TEXT_SECTION is set during final asm output only. */ - v = iterative_hash_host_wide_int (DECL_HARD_REGISTER (t) - | (DECL_IN_CONSTANT_POOL (t) << 1), - v); + hstate.add_flag (DECL_HARD_REGISTER (t)); + hstate.add_flag (DECL_IN_CONSTANT_POOL (t)); } if (TREE_CODE (t) == FUNCTION_DECL) - v = iterative_hash_host_wide_int (DECL_FINAL_P (t) - | (DECL_CXX_CONSTRUCTOR_P (t) << 1) - | (DECL_CXX_DESTRUCTOR_P (t) << 2), - v); + { + hstate.add_flag (DECL_FINAL_P (t)); + hstate.add_flag (DECL_CXX_CONSTRUCTOR_P (t)); + hstate.add_flag (DECL_CXX_DESTRUCTOR_P (t)); + } + hstate.commit_flag (); } if (CODE_CONTAINS_STRUCT (code, TS_FUNCTION_DECL)) { - v = iterative_hash_host_wide_int (DECL_BUILT_IN_CLASS (t), v); - v = iterative_hash_host_wide_int (DECL_STATIC_CONSTRUCTOR (t) - | (DECL_STATIC_DESTRUCTOR (t) << 1) - | (DECL_UNINLINABLE (t) << 2) - | (DECL_POSSIBLY_INLINED (t) << 3) - | (DECL_IS_NOVOPS (t) << 4) - | (DECL_IS_RETURNS_TWICE (t) << 5) - | (DECL_IS_MALLOC (t) << 6) - | (DECL_IS_OPERATOR_NEW (t) << 7) - | (DECL_DECLARED_INLINE_P (t) << 8) - | (DECL_STATIC_CHAIN (t) << 9) - | (DECL_NO_INLINE_WARNING_P (t) << 10) - | (DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT (t) << 11) - | (DECL_NO_LIMIT_STACK (t) << 12) - | (DECL_DISREGARD_INLINE_LIMITS (t) << 13) - | (DECL_PURE_P (t) << 14) - | (DECL_LOOPING_CONST_OR_PURE_P (t) << 15), v); + hstate.add_int (DECL_BUILT_IN_CLASS (t)); + hstate.add_flag (DECL_STATIC_CONSTRUCTOR (t)); + hstate.add_flag (DECL_STATIC_DESTRUCTOR (t)); + hstate.add_flag (DECL_UNINLINABLE (t)); + hstate.add_flag (DECL_POSSIBLY_INLINED (t)); + hstate.add_flag (DECL_IS_NOVOPS (t)); + hstate.add_flag (DECL_IS_RETURNS_TWICE (t)); + hstate.add_flag (DECL_IS_MALLOC (t)); + hstate.add_flag (DECL_IS_OPERATOR_NEW (t)); + hstate.add_flag (DECL_DECLARED_INLINE_P (t)); + hstate.add_flag (DECL_STATIC_CHAIN (t)); + hstate.add_flag (DECL_NO_INLINE_WARNING_P (t)); + hstate.add_flag (DECL_NO_INSTRUMENT_FUNCTION_ENTRY_EXIT (t)); + hstate.add_flag (DECL_NO_LIMIT_STACK (t)); + hstate.add_flag (DECL_DISREGARD_INLINE_LIMITS (t)); + hstate.add_flag (DECL_PURE_P (t)); + hstate.add_flag (DECL_LOOPING_CONST_OR_PURE_P (t)); + hstate.commit_flag (); if (DECL_BUILT_IN_CLASS (t) != NOT_BUILT_IN) - v = iterative_hash_host_wide_int (DECL_FUNCTION_CODE (t), v); + hstate.add_int (DECL_FUNCTION_CODE (t)); } if (CODE_CONTAINS_STRUCT (code, TS_TYPE_COMMON)) { - v = iterative_hash_host_wide_int (TYPE_MODE (t), v); - v = iterative_hash_host_wide_int (TYPE_STRING_FLAG (t) - | (TYPE_NO_FORCE_BLK (t) << 1) - | (TYPE_NEEDS_CONSTRUCTING (t) << 2) - | (TYPE_PACKED (t) << 3) - | (TYPE_RESTRICT (t) << 4) - | (TYPE_USER_ALIGN (t) << 5) - | (TYPE_READONLY (t) << 6), v); + hstate.add_wide_int (TYPE_MODE (t)); + hstate.add_flag (TYPE_STRING_FLAG (t)); + hstate.add_flag (TYPE_NO_FORCE_BLK (t)); + hstate.add_flag (TYPE_NEEDS_CONSTRUCTING (t)); + hstate.add_flag (TYPE_PACKED (t)); + hstate.add_flag (TYPE_RESTRICT (t)); + hstate.add_flag (TYPE_USER_ALIGN (t)); + hstate.add_flag (TYPE_READONLY (t)); if (RECORD_OR_UNION_TYPE_P (t)) { - v = iterative_hash_host_wide_int (TYPE_TRANSPARENT_AGGR (t) - | (TYPE_FINAL_P (t) << 1), v); + hstate.add_flag (TYPE_TRANSPARENT_AGGR (t)); + hstate.add_flag (TYPE_FINAL_P (t)); } else if (code == ARRAY_TYPE) - v = iterative_hash_host_wide_int (TYPE_NONALIASED_COMPONENT (t), v); - v = iterative_hash_host_wide_int (TYPE_PRECISION (t), v); - v = iterative_hash_host_wide_int (TYPE_ALIGN (t), v); - v = iterative_hash_host_wide_int ((TYPE_ALIAS_SET (t) == 0 + hstate.add_flag (TYPE_NONALIASED_COMPONENT (t)); + hstate.commit_flag (); + hstate.add_int (TYPE_PRECISION (t)); + hstate.add_int (TYPE_ALIGN (t)); + hstate.add_int ((TYPE_ALIAS_SET (t) == 0 || (!in_lto_p && get_alias_set (t) == 0)) - ? 0 : -1, v); + ? 0 : -1); } if (CODE_CONTAINS_STRUCT (code, TS_TRANSLATION_UNIT_DECL)) - v = iterative_hash (TRANSLATION_UNIT_LANGUAGE (t), - strlen (TRANSLATION_UNIT_LANGUAGE (t)), v); + hstate.add (TRANSLATION_UNIT_LANGUAGE (t), + strlen (TRANSLATION_UNIT_LANGUAGE (t))); if (CODE_CONTAINS_STRUCT (code, TS_TARGET_OPTION)) gcc_unreachable (); if (CODE_CONTAINS_STRUCT (code, TS_OPTIMIZATION)) - v = iterative_hash (t, sizeof (struct cl_optimization), v); + hstate.add (t, sizeof (struct cl_optimization)); if (CODE_CONTAINS_STRUCT (code, TS_IDENTIFIER)) - v = iterative_hash_host_wide_int (IDENTIFIER_HASH_VALUE (t), v); + hstate.merge_hash (IDENTIFIER_HASH_VALUE (t)); if (CODE_CONTAINS_STRUCT (code, TS_STRING)) - v = iterative_hash (TREE_STRING_POINTER (t), TREE_STRING_LENGTH (t), v); + hstate.add (TREE_STRING_POINTER (t), TREE_STRING_LENGTH (t)); if (CODE_CONTAINS_STRUCT (code, TS_TYPED)) { - if (POINTER_TYPE_P (t)) - { - /* For pointers factor in the pointed-to type recursively as - we cannot recurse through only pointers. - ??? We can generalize this by keeping track of the - in-SCC edges for each tree (or arbitrarily the first - such edge) and hashing that in in a second stage - (instead of the quadratic mixing of the SCC we do now). */ - hashval_t x; - unsigned ix; - if (streamer_tree_cache_lookup (cache, TREE_TYPE (t), &ix)) - x = streamer_tree_cache_get_hash (cache, ix); - else - x = hash_tree (cache, TREE_TYPE (t)); - v = iterative_hash_hashval_t (x, v); - } - else if (code != IDENTIFIER_NODE) + if (code != IDENTIFIER_NODE) visit (TREE_TYPE (t)); } @@ -1034,7 +1069,7 @@ hash_tree (struct streamer_tree_cache_d *cache, tree t) if (CODE_CONTAINS_STRUCT (code, TS_EXP)) { - v = iterative_hash_host_wide_int (TREE_OPERAND_LENGTH (t), v); + hstate.add_wide_int (TREE_OPERAND_LENGTH (t)); for (int i = 0; i < TREE_OPERAND_LENGTH (t); ++i) visit (TREE_OPERAND (t, i)); } @@ -1058,7 +1093,7 @@ hash_tree (struct streamer_tree_cache_d *cache, tree t) { unsigned i; tree index, value; - v = iterative_hash_host_wide_int (CONSTRUCTOR_NELTS (t), v); + hstate.add_wide_int (CONSTRUCTOR_NELTS (t)); FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (t), i, index, value) { visit (index); @@ -1069,45 +1104,48 @@ hash_tree (struct streamer_tree_cache_d *cache, tree t) if (code == OMP_CLAUSE) { int i; + HOST_WIDE_INT val; - v = iterative_hash_host_wide_int (OMP_CLAUSE_CODE (t), v); + hstate.add_wide_int (OMP_CLAUSE_CODE (t)); switch (OMP_CLAUSE_CODE (t)) { case OMP_CLAUSE_DEFAULT: - v = iterative_hash_host_wide_int (OMP_CLAUSE_DEFAULT_KIND (t), v); + val = OMP_CLAUSE_DEFAULT_KIND (t); break; case OMP_CLAUSE_SCHEDULE: - v = iterative_hash_host_wide_int (OMP_CLAUSE_SCHEDULE_KIND (t), v); + val = OMP_CLAUSE_SCHEDULE_KIND (t); break; case OMP_CLAUSE_DEPEND: - v = iterative_hash_host_wide_int (OMP_CLAUSE_DEPEND_KIND (t), v); + val = OMP_CLAUSE_DEPEND_KIND (t); break; case OMP_CLAUSE_MAP: - v = iterative_hash_host_wide_int (OMP_CLAUSE_MAP_KIND (t), v); + val = OMP_CLAUSE_MAP_KIND (t); break; case OMP_CLAUSE_PROC_BIND: - v = iterative_hash_host_wide_int (OMP_CLAUSE_PROC_BIND_KIND (t), v); + val = OMP_CLAUSE_PROC_BIND_KIND (t); break; case OMP_CLAUSE_REDUCTION: - v = iterative_hash_host_wide_int (OMP_CLAUSE_REDUCTION_CODE (t), v); + val = OMP_CLAUSE_REDUCTION_CODE (t); break; default: + val = 0; break; } + hstate.add_wide_int (val); for (i = 0; i < omp_clause_num_ops[OMP_CLAUSE_CODE (t)]; i++) visit (OMP_CLAUSE_OPERAND (t, i)); visit (OMP_CLAUSE_CHAIN (t)); } - return v; + return hstate.end (); #undef visit } /* Compare two SCC entries by their hash value for qsorting them. */ -static int -scc_entry_compare (const void *p1_, const void *p2_) +int +DFS::scc_entry_compare (const void *p1_, const void *p2_) { const scc_entry *p1 = (const scc_entry *) p1_; const scc_entry *p2 = (const scc_entry *) p2_; @@ -1121,40 +1159,159 @@ scc_entry_compare (const void *p1_, const void *p2_) /* Return a hash value for the SCC on the SCC stack from FIRST with size SIZE. */ -static hashval_t -hash_scc (struct streamer_tree_cache_d *cache, unsigned first, unsigned size) +hashval_t +DFS::hash_scc (struct output_block *ob, + unsigned first, unsigned size) { + unsigned int last_classes = 0, iterations = 0; + /* Compute hash values for the SCC members. */ for (unsigned i = 0; i < size; ++i) - sccstack[first+i].hash = hash_tree (cache, sccstack[first+i].t); + sccstack[first+i].hash = hash_tree (ob->writer_cache, NULL, + sccstack[first+i].t); if (size == 1) return sccstack[first].hash; - /* Sort the SCC of type, hash pairs so that when we mix in - all members of the SCC the hash value becomes independent on - the order we visited the SCC. Produce hash of the whole SCC as - combination of hashes of individual elements. Then combine that hash into - hash of each element, so othewise identically looking elements from two - different SCCs are distinguished. */ - qsort (&sccstack[first], size, sizeof (scc_entry), scc_entry_compare); - - hashval_t scc_hash = sccstack[first].hash; - for (unsigned i = 1; i < size; ++i) - scc_hash = iterative_hash_hashval_t (scc_hash, - sccstack[first+i].hash); - for (unsigned i = 0; i < size; ++i) - sccstack[first+i].hash = iterative_hash_hashval_t (sccstack[first+i].hash, scc_hash); - return scc_hash; + /* We aim to get unique hash for every tree within SCC and compute hash value + of the whole SCC by combing all values together in an stable (entry point + independent) order. This guarantees that the same SCC regions within + different translation units will get the same hash values and therefore + will be merged at WPA time. + + Often the hashes are already unique. In that case we compute scc hash + by combining individual hash values in an increasing order. + + If thre are duplicates we seek at least one tree with unique hash (and + pick one with minimal hash and this property). Then we obtain stable + order by DFS walk starting from this unique tree and then use index + within this order to make individual hash values unique. + + If there is no tree with unique hash, we iteratively propagate the hash + values across the internal edges of SCC. This usually quickly leads + to unique hashes. Consider, for example, an SCC containing two pointers + that are identical except for type they point and assume that these + types are also part of the SCC. + The propagation will add the points-to type information into their hash + values. */ + do + { + /* Sort the SCC so we can easily see check for uniqueness. */ + qsort (&sccstack[first], size, sizeof (scc_entry), scc_entry_compare); + + unsigned int classes = 1; + int firstunique = -1; + + /* Find tree with lowest unique hash (if it exists) and compute + number of equivalence classes. */ + if (sccstack[first].hash != sccstack[first+1].hash) + firstunique = 0; + for (unsigned i = 1; i < size; ++i) + if (sccstack[first+i-1].hash != sccstack[first+i].hash) + { + classes++; + if (firstunique == -1 + && (i == size - 1 + || sccstack[first+i+1].hash != sccstack[first+i].hash)) + firstunique = i; + } + + /* If we found tree with unique hash; stop the iteration. */ + if (firstunique != -1 + /* Also terminate if we run out of iterations or if the number of + equivalence classes is no longer increasing. + For example a cyclic list of trees that are all equivalent will + never have unique entry point; we however do not build such SCCs + in our IL. */ + || classes <= last_classes || iterations > 16) + { + hashval_t scc_hash; + + /* If some hashes are not unique (CLASSES != SIZE), use the DFS walk + starting from FIRSTUNIQUE to obstain stable order. */ + if (classes != size && firstunique != -1) + { + hash_map map(size*2); + + /* Store hash values into a map, so we can associate them with + reordered SCC. */ + for (unsigned i = 0; i < size; ++i) + map.put (sccstack[first+i].t, sccstack[first+i].hash); + + DFS again (ob, sccstack[first+firstunique].t, false, false, true); + gcc_assert (again.sccstack.length () == size); + + memcpy (sccstack.address () + first, + again.sccstack.address (), + sizeof (scc_entry) * size); + + /* Update hash values of individual members by hashing in the + index within the stable order. This ensures uniqueness. + Also compute the scc_hash by mixing in all hash values in the + stable order we obtained. */ + sccstack[first].hash = *map.get (sccstack[first].t); + scc_hash = sccstack[first].hash; + for (unsigned i = 1; i < size; ++i) + { + sccstack[first+i].hash + = iterative_hash_hashval_t (i, + *map.get (sccstack[first+i].t)); + scc_hash = iterative_hash_hashval_t (scc_hash, + sccstack[first+i].hash); + } + } + /* If we got unique hash values for each tree, then sort already + ensured entry point independent order. Only compute the final + scc hash. + + If we failed to find the unique entry point, we go by the same + route. We will eventually introduce unwanted hash conflicts. */ + else + { + scc_hash = sccstack[first].hash; + for (unsigned i = 1; i < size; ++i) + scc_hash = iterative_hash_hashval_t (scc_hash, + sccstack[first+i].hash); + /* We can not 100% guarantee that the hash will not conflict in + in a way so the unique hash is not found. This however + should be extremely rare situation. ICE for now so possible + issues are found and evaulated. */ + gcc_checking_assert (classes == size); + } + + /* To avoid conflicts across SCCs iteratively hash the whole SCC + hash into the hash of each of the elements. */ + for (unsigned i = 0; i < size; ++i) + sccstack[first+i].hash + = iterative_hash_hashval_t (sccstack[first+i].hash, scc_hash); + return scc_hash; + } + + last_classes = classes; + iterations++; + + /* We failed to identify the entry point; propagate hash values across + the edges. */ + { + hash_map map(size*2); + for (unsigned i = 0; i < size; ++i) + map.put (sccstack[first+i].t, sccstack[first+i].hash); + + for (unsigned i = 0; i < size; i++) + sccstack[first+i].hash = hash_tree (ob->writer_cache, &map, + sccstack[first+i].t); + } + } + while (true); } /* DFS walk EXPR and stream SCCs of tree bodies if they are not already in the streamer cache. Main routine called for each visit of EXPR. */ -static void -DFS_write_tree (struct output_block *ob, sccs *from_state, - tree expr, bool ref_p, bool this_ref_p) +void +DFS::DFS_write_tree (struct output_block *ob, sccs *from_state, + tree expr, bool ref_p, bool this_ref_p, bool single_p) { unsigned ix; sccs **slot; @@ -1186,10 +1343,10 @@ DFS_write_tree (struct output_block *ob, sccs *from_state, ; else if (TREE_CODE (expr) == INTEGER_CST && !TREE_OVERFLOW (expr)) - DFS_write_tree (ob, cstate, TREE_TYPE (expr), ref_p, ref_p); + DFS_write_tree (ob, cstate, TREE_TYPE (expr), ref_p, ref_p, single_p); else { - DFS_write_tree_body (ob, expr, cstate, ref_p); + DFS_write_tree_body (ob, expr, cstate, ref_p, single_p); /* Walk any LTO-specific edges. */ if (DECL_P (expr) @@ -1199,7 +1356,7 @@ DFS_write_tree (struct output_block *ob, sccs *from_state, /* Handle DECL_INITIAL for symbols. */ tree initial = get_symbol_initial_value (ob->decl_state->symtab_node_encoder, expr); - DFS_write_tree (ob, cstate, initial, ref_p, ref_p); + DFS_write_tree (ob, cstate, initial, ref_p, ref_p, single_p); } } @@ -1209,6 +1366,11 @@ DFS_write_tree (struct output_block *ob, sccs *from_state, unsigned first, size; tree x; + /* If we are re-walking a single leaf-SCC just return and + let the caller access the sccstack. */ + if (single_p) + return; + /* Pop the SCC and compute its size. */ first = sccstack.length (); do @@ -1224,7 +1386,7 @@ DFS_write_tree (struct output_block *ob, sccs *from_state, unsigned scc_entry_len = 0; if (!flag_wpa) { - scc_hash = hash_scc (ob->writer_cache, first, size); + scc_hash = hash_scc (ob, first, size); /* Put the entries with the least number of collisions first. */ unsigned entry_start = 0; @@ -1248,6 +1410,18 @@ DFS_write_tree (struct output_block *ob, sccs *from_state, sccstack[first + i] = sccstack[first + entry_start + i]; sccstack[first + entry_start + i] = tem; } + + if (scc_entry_len == 1) + ; /* We already sorted SCC deterministically in hash_scc. */ + else + /* Check that we have only one SCC. + Naturally we may have conflicts if hash function is not + strong enough. Lets see how far this gets. */ + { +#ifdef ENABLE_CHECKING + gcc_unreachable (); +#endif + } } /* Write LTO_tree_scc. */ @@ -1367,13 +1541,7 @@ lto_output_tree (struct output_block *ob, tree expr, /* Save ob state ... */ /* let's see ... */ in_dfs_walk = true; - sccstate = pointer_map_create (); - gcc_obstack_init (&sccstate_obstack); - next_dfs_num = 1; - DFS_write_tree (ob, NULL, expr, ref_p, this_ref_p); - sccstack.release (); - pointer_map_destroy (sccstate); - obstack_free (&sccstate_obstack, NULL); + DFS (ob, expr, ref_p, this_ref_p, false); in_dfs_walk = false; /* Finally append a reference to the tree we were writing. @@ -1705,7 +1873,6 @@ produce_asm (struct output_block *ob, tree fn) enum lto_section_type section_type = ob->section_type; struct lto_function_header header; char *section_name; - struct lto_output_stream *header_stream; if (section_type == LTO_section_function_body) { @@ -1731,11 +1898,7 @@ produce_asm (struct output_block *ob, tree fn) header.cfg_size = ob->cfg_stream->total_size; header.main_size = ob->main_stream->total_size; header.string_size = ob->string_stream->total_size; - - header_stream = XCNEW (struct lto_output_stream); - lto_output_data_stream (header_stream, &header, sizeof header); - lto_write_stream (header_stream); - free (header_stream); + lto_write_data (&header, sizeof header); /* Put all of the gimple and the string table out the asm file as a block of text. */ @@ -1937,7 +2100,6 @@ lto_output_toplevel_asms (void) struct output_block *ob; struct asm_node *can; char *section_name; - struct lto_output_stream *header_stream; struct lto_asm_header header; if (! asm_nodes) @@ -1969,11 +2131,7 @@ lto_output_toplevel_asms (void) header.main_size = ob->main_stream->total_size; header.string_size = ob->string_stream->total_size; - - header_stream = XCNEW (struct lto_output_stream); - lto_output_data_stream (header_stream, &header, sizeof (header)); - lto_write_stream (header_stream); - free (header_stream); + lto_write_data (&header, sizeof header); /* Put all of the gimple and the string table out the asm file as a block of text. */ @@ -1993,7 +2151,6 @@ copy_function_or_variable (struct symtab_node *node) { tree function = node->decl; struct lto_file_decl_data *file_data = node->lto_file_data; - struct lto_output_stream *output_stream = XCNEW (struct lto_output_stream); const char *data; size_t len; const char *name = IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (function)); @@ -2014,8 +2171,7 @@ copy_function_or_variable (struct symtab_node *node) gcc_assert (data); /* Do a bit copy of the function body. */ - lto_output_data_stream (output_stream, data, len); - lto_write_stream (output_stream); + lto_write_data (data, len); /* Copy decls. */ in_state = @@ -2039,7 +2195,6 @@ copy_function_or_variable (struct symtab_node *node) lto_free_section_data (file_data, LTO_section_function_body, name, data, len); - free (output_stream); lto_end_section (); } @@ -2181,15 +2336,15 @@ write_global_stream (struct output_block *ob, static void write_global_references (struct output_block *ob, - struct lto_output_stream *ref_stream, struct lto_tree_ref_encoder *encoder) { tree t; uint32_t index; const uint32_t size = lto_tree_ref_encoder_size (encoder); - /* Write size as 32-bit unsigned. */ - lto_output_data_stream (ref_stream, &size, sizeof (int32_t)); + /* Write size and slot indexes as 32-bit unsigned numbers. */ + uint32_t *data = XNEWVEC (uint32_t, size + 1); + data[0] = size; for (index = 0; index < size; index++) { @@ -2198,8 +2353,11 @@ write_global_references (struct output_block *ob, t = lto_tree_ref_encoder_get_tree (encoder, index); streamer_tree_cache_lookup (ob->writer_cache, t, &slot_num); gcc_assert (slot_num != (unsigned)-1); - lto_output_data_stream (ref_stream, &slot_num, sizeof slot_num); + data[index + 1] = slot_num; } + + lto_write_data (data, sizeof (int32_t) * (size + 1)); + free (data); } @@ -2222,7 +2380,6 @@ lto_output_decl_state_streams (struct output_block *ob, void lto_output_decl_state_refs (struct output_block *ob, - struct lto_output_stream *out_stream, struct lto_out_decl_state *state) { unsigned i; @@ -2234,10 +2391,10 @@ lto_output_decl_state_refs (struct output_block *ob, decl = (state->fn_decl) ? state->fn_decl : void_type_node; streamer_tree_cache_lookup (ob->writer_cache, decl, &ref); gcc_assert (ref != (unsigned)-1); - lto_output_data_stream (out_stream, &ref, sizeof (uint32_t)); + lto_write_data (&ref, sizeof (uint32_t)); for (i = 0; i < LTO_N_DECL_STREAMS; i++) - write_global_references (ob, out_stream, &state->streams[i]); + write_global_references (ob, &state->streams[i]); } @@ -2265,8 +2422,7 @@ lto_out_decl_state_written_size (struct lto_out_decl_state *state) static void write_symbol (struct streamer_tree_cache_d *cache, - struct lto_output_stream *stream, - tree t, struct pointer_set_t *seen, bool alias) + tree t, hash_set *seen, bool alias) { const char *name; enum gcc_plugin_symbol_kind kind; @@ -2294,9 +2450,8 @@ write_symbol (struct streamer_tree_cache_d *cache, same name manipulations that ASM_OUTPUT_LABELREF does. */ name = IDENTIFIER_POINTER ((*targetm.asm_out.mangle_assembler_name) (name)); - if (pointer_set_contains (seen, name)) + if (seen->add (name)) return; - pointer_set_insert (seen, name); streamer_tree_cache_lookup (cache, t, &slot_num); gcc_assert (slot_num != (unsigned)-1); @@ -2364,14 +2519,14 @@ write_symbol (struct streamer_tree_cache_d *cache, else comdat = ""; - lto_output_data_stream (stream, name, strlen (name) + 1); - lto_output_data_stream (stream, comdat, strlen (comdat) + 1); + lto_write_data (name, strlen (name) + 1); + lto_write_data (comdat, strlen (comdat) + 1); c = (unsigned char) kind; - lto_output_data_stream (stream, &c, 1); + lto_write_data (&c, 1); c = (unsigned char) visibility; - lto_output_data_stream (stream, &c, 1); - lto_output_data_stream (stream, &size, 8); - lto_output_data_stream (stream, &slot_num, 4); + lto_write_data (&c, 1); + lto_write_data (&size, 8); + lto_write_data (&slot_num, 4); } /* Return true if NODE should appear in the plugin symbol table. */ @@ -2421,16 +2576,13 @@ produce_symtab (struct output_block *ob) { struct streamer_tree_cache_d *cache = ob->writer_cache; char *section_name = lto_get_section_name (LTO_section_symtab, NULL, NULL); - struct pointer_set_t *seen; - struct lto_output_stream stream; lto_symtab_encoder_t encoder = ob->decl_state->symtab_node_encoder; lto_symtab_encoder_iterator lsei; lto_begin_section (section_name, false); free (section_name); - seen = pointer_set_create (); - memset (&stream, 0, sizeof (stream)); + hash_set seen; /* Write the symbol table. First write everything defined and then all declarations. @@ -2442,7 +2594,7 @@ produce_symtab (struct output_block *ob) if (!output_symbol_p (node) || DECL_EXTERNAL (node->decl)) continue; - write_symbol (cache, &stream, node->decl, seen, false); + write_symbol (cache, node->decl, &seen, false); } for (lsei = lsei_start (encoder); !lsei_end_p (lsei); lsei_next (&lsei)) @@ -2451,12 +2603,9 @@ produce_symtab (struct output_block *ob) if (!output_symbol_p (node) || !DECL_EXTERNAL (node->decl)) continue; - write_symbol (cache, &stream, node->decl, seen, false); + write_symbol (cache, node->decl, &seen, false); } - lto_write_stream (&stream); - pointer_set_destroy (seen); - lto_end_section (); } @@ -2475,13 +2624,11 @@ produce_asm_for_decls (void) struct lto_decl_header header; char *section_name; struct output_block *ob; - struct lto_output_stream *header_stream, *decl_state_stream; unsigned idx, num_fns; size_t decl_state_size; int32_t num_decl_states; ob = create_output_block (LTO_section_decls); - ob->global = true; memset (&header, 0, sizeof (struct lto_decl_header)); @@ -2534,26 +2681,18 @@ produce_asm_for_decls (void) header.main_size = ob->main_stream->total_size; header.string_size = ob->string_stream->total_size; - header_stream = XCNEW (struct lto_output_stream); - lto_output_data_stream (header_stream, &header, sizeof header); - lto_write_stream (header_stream); - free (header_stream); + lto_write_data (&header, sizeof header); /* Write the main out-decl state, followed by out-decl states of functions. */ - decl_state_stream = XCNEW (struct lto_output_stream); num_decl_states = num_fns + 1; - lto_output_data_stream (decl_state_stream, &num_decl_states, - sizeof (num_decl_states)); - lto_output_decl_state_refs (ob, decl_state_stream, out_state); + lto_write_data (&num_decl_states, sizeof (num_decl_states)); + lto_output_decl_state_refs (ob, out_state); for (idx = 0; idx < num_fns; idx++) { - fn_out_state = - lto_function_decl_states[idx]; - lto_output_decl_state_refs (ob, decl_state_stream, fn_out_state); + fn_out_state = lto_function_decl_states[idx]; + lto_output_decl_state_refs (ob, fn_out_state); } - lto_write_stream (decl_state_stream); - free (decl_state_stream); lto_write_stream (ob->main_stream); lto_write_stream (ob->string_stream); diff --git a/main/gcc/lto-streamer.h b/main/gcc/lto-streamer.h index d350ad9cedb..7cab1cbc5e3 100644 --- a/main/gcc/lto-streamer.h +++ b/main/gcc/lto-streamer.h @@ -443,7 +443,7 @@ struct lto_encoder_entry struct lto_symtab_encoder_d { vec nodes; - pointer_map_t *map; + hash_map *map; }; typedef struct lto_symtab_encoder_d *lto_symtab_encoder_t; @@ -696,9 +696,6 @@ struct output_block int current_line; int current_col; - /* True if writing globals and types. */ - bool global; - /* Cache of nodes written in this section. */ struct streamer_tree_cache_d *writer_cache; @@ -714,22 +711,12 @@ struct data_in /* The global decls and types. */ struct lto_file_decl_data *file_data; - /* All of the labels. */ - tree *labels; - /* The string table. */ const char *strings; /* The length of the string table. */ unsigned int strings_len; - /* Number of named labels. Used to find the index of unnamed labels - since they share space with the named labels. */ - unsigned int num_named_labels; - - /* Number of unnamed labels. */ - unsigned int num_unnamed_labels; - /* Maps each reference number to the resolution done by the linker. */ vec globals_resolution; @@ -777,9 +764,8 @@ extern void lto_value_range_error (const char *, /* In lto-section-out.c */ extern void lto_begin_section (const char *, bool); extern void lto_end_section (void); +extern void lto_write_data (const void *, unsigned int); extern void lto_write_stream (struct lto_output_stream *); -extern void lto_output_data_stream (struct lto_output_stream *, const void *, - size_t); extern bool lto_output_decl_index (struct lto_output_stream *, struct lto_tree_ref_encoder *, tree, unsigned int *); @@ -1046,8 +1032,8 @@ static inline int lto_symtab_encoder_lookup (lto_symtab_encoder_t encoder, symtab_node *node) { - void **slot = pointer_map_contains (encoder->map, node); - return (slot && *slot ? (size_t) *(slot) - 1 : LCC_NOT_FOUND); + size_t *slot = encoder->map->get (node); + return (slot && *slot ? *(slot) - 1 : LCC_NOT_FOUND); } /* Return true if iterator LSE points to nothing. */ diff --git a/main/gcc/lto/ChangeLog b/main/gcc/lto/ChangeLog index 8fd21ea828f..2d0018ff42e 100644 --- a/main/gcc/lto/ChangeLog +++ b/main/gcc/lto/ChangeLog @@ -1,3 +1,45 @@ +2014-08-02 Trevor Saunders + + * lto-partition.c, lto-partition.h: Use hash_set instead of + pointer_set. + +2014-07-31 Andi Kleen + + * lto.c (hash_canonical_type): Use inchash::hash + and use inchash::add_expr. + (iterative_hash_canonical_type): Dito. + +2014-07-30 Richard Biener + + * lto-streamer.h (lto_write_data): New function. + * langhooks.c (lhd_append_data): Do not free block. + * lto-section-out.c (lto_write_data): New function writing + raw data to the current section. + (lto_write_stream): Adjust for langhook semantic change. + (lto_destroy_simple_output_block): Write header directly. + * lto-opts.c (lto_write_options): Write options directly. + * lto-streamer-out.c (produce_asm): Write heaeder directly. + (lto_output_toplevel_asms): Likewise. + (copy_function_or_variable): Copy data directly. + (write_global_references): Output index table directly. + (lto_output_decl_state_refs): Likewise. + (write_symbol): Write data directly. + (produce_symtab): Adjust. + (produce_asm_for_decls): Output header and refs directly. + +2014-07-25 Andi Kleen + + * lto.c (hash_canonical_type): Call iterative_hstate_expr. + +2014-07-25 Andi Kleen + + * lto.c (hash_canonical_type): Convert to inchash. + (iterative_hash_canonical_type): Dito. + +2014-07-25 Andi Kleen + + * lto.c: Include inchash.h + 2014-07-14 Jan Hubicka * lto.c (mentions_vars_p_decl_non_common): Skip diff --git a/main/gcc/lto/lto-object.c b/main/gcc/lto/lto-object.c index c406efb3c30..323f7b2a74e 100644 --- a/main/gcc/lto/lto-object.c +++ b/main/gcc/lto/lto-object.c @@ -354,7 +354,7 @@ lto_obj_begin_section (const char *name) DATA. */ void -lto_obj_append_data (const void *data, size_t len, void *block) +lto_obj_append_data (const void *data, size_t len, void *) { struct lto_simple_object *lo; const char *errmsg; @@ -372,8 +372,6 @@ lto_obj_append_data (const void *data, size_t len, void *block) else fatal_error ("%s: %s", errmsg, xstrerror (errno)); } - - free (block); } /* Stop writing to the current output section. */ diff --git a/main/gcc/lto/lto-partition.c b/main/gcc/lto/lto-partition.c index cb08a88ad0e..a5bcf92a2fe 100644 --- a/main/gcc/lto/lto-partition.c +++ b/main/gcc/lto/lto-partition.c @@ -66,7 +66,7 @@ free_ltrans_partitions (void) for (idx = 0; ltrans_partitions.iterate (idx, &part); idx++) { if (part->initializers_visited) - pointer_set_destroy (part->initializers_visited); + delete part->initializers_visited; /* Symtab encoder is freed after streaming. */ free (part); } @@ -101,8 +101,8 @@ add_references_to_partition (ltrans_partition part, symtab_node *node) && !lto_symtab_encoder_in_partition_p (part->encoder, ref->referred)) { if (!part->initializers_visited) - part->initializers_visited = pointer_set_create (); - if (!pointer_set_insert (part->initializers_visited, ref->referred)) + part->initializers_visited = new hash_set; + if (!part->initializers_visited->add (ref->referred)) add_references_to_partition (part, ref->referred); } } @@ -250,7 +250,7 @@ undo_partition (ltrans_partition partition, unsigned int n_nodes) /* After UNDO we no longer know what was visited. */ if (partition->initializers_visited) - pointer_set_destroy (partition->initializers_visited); + delete partition->initializers_visited; partition->initializers_visited = NULL; if (!node->alias && (cnode = dyn_cast (node))) diff --git a/main/gcc/lto/lto-partition.h b/main/gcc/lto/lto-partition.h index 8db61b30176..50ec2faffcf 100644 --- a/main/gcc/lto/lto-partition.h +++ b/main/gcc/lto/lto-partition.h @@ -17,6 +17,7 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ +#include "hash-set.h" /* Structure describing ltrans partitions. */ @@ -25,7 +26,7 @@ struct ltrans_partition_def lto_symtab_encoder_t encoder; const char * name; int insns; - pointer_set_t *initializers_visited; + hash_set *initializers_visited; }; typedef struct ltrans_partition_def *ltrans_partition; diff --git a/main/gcc/lto/lto.c b/main/gcc/lto/lto.c index 683120c0081..7ecdec25808 100644 --- a/main/gcc/lto/lto.c +++ b/main/gcc/lto/lto.c @@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see #include "langhooks.h" #include "bitmap.h" #include "hash-map.h" +#include "inchash.h" #include "ipa-prop.h" #include "common.h" #include "debug.h" @@ -266,7 +267,7 @@ static hash_map *canonical_type_hash_cache; static unsigned long num_canonical_type_hash_entries; static unsigned long num_canonical_type_hash_queries; -static hashval_t iterative_hash_canonical_type (tree type, hashval_t val); +static void iterative_hash_canonical_type (tree type, inchash::hash &hstate); static hashval_t gimple_canonical_type_hash (const void *p); static void gimple_register_canonical_type_1 (tree t, hashval_t hash); @@ -278,14 +279,14 @@ static void gimple_register_canonical_type_1 (tree t, hashval_t hash); static hashval_t hash_canonical_type (tree type) { - hashval_t v; + inchash::hash hstate; /* Combine a few common features of types so that types are grouped into smaller sets; when searching for existing matching types to merge, only existing types having the same features as the new type will be checked. */ - v = iterative_hash_hashval_t (TREE_CODE (type), 0); - v = iterative_hash_hashval_t (TYPE_MODE (type), v); + hstate.add_int (TREE_CODE (type)); + hstate.add_int (TYPE_MODE (type)); /* Incorporate common features of numerical types. */ if (INTEGRAL_TYPE_P (type) @@ -294,48 +295,48 @@ hash_canonical_type (tree type) || TREE_CODE (type) == OFFSET_TYPE || POINTER_TYPE_P (type)) { - v = iterative_hash_hashval_t (TYPE_PRECISION (type), v); - v = iterative_hash_hashval_t (TYPE_UNSIGNED (type), v); + hstate.add_int (TYPE_UNSIGNED (type)); + hstate.add_int (TYPE_PRECISION (type)); } if (VECTOR_TYPE_P (type)) { - v = iterative_hash_hashval_t (TYPE_VECTOR_SUBPARTS (type), v); - v = iterative_hash_hashval_t (TYPE_UNSIGNED (type), v); + hstate.add_int (TYPE_VECTOR_SUBPARTS (type)); + hstate.add_int (TYPE_UNSIGNED (type)); } if (TREE_CODE (type) == COMPLEX_TYPE) - v = iterative_hash_hashval_t (TYPE_UNSIGNED (type), v); + hstate.add_int (TYPE_UNSIGNED (type)); /* For pointer and reference types, fold in information about the type pointed to but do not recurse to the pointed-to type. */ if (POINTER_TYPE_P (type)) { - v = iterative_hash_hashval_t (TYPE_ADDR_SPACE (TREE_TYPE (type)), v); - v = iterative_hash_hashval_t (TREE_CODE (TREE_TYPE (type)), v); + hstate.add_int (TYPE_ADDR_SPACE (TREE_TYPE (type))); + hstate.add_int (TREE_CODE (TREE_TYPE (type))); } /* For integer types hash only the string flag. */ if (TREE_CODE (type) == INTEGER_TYPE) - v = iterative_hash_hashval_t (TYPE_STRING_FLAG (type), v); + hstate.add_int (TYPE_STRING_FLAG (type)); /* For array types hash the domain bounds and the string flag. */ if (TREE_CODE (type) == ARRAY_TYPE && TYPE_DOMAIN (type)) { - v = iterative_hash_hashval_t (TYPE_STRING_FLAG (type), v); + hstate.add_int (TYPE_STRING_FLAG (type)); /* OMP lowering can introduce error_mark_node in place of random local decls in types. */ if (TYPE_MIN_VALUE (TYPE_DOMAIN (type)) != error_mark_node) - v = iterative_hash_expr (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), v); + inchash::add_expr (TYPE_MIN_VALUE (TYPE_DOMAIN (type)), hstate); if (TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != error_mark_node) - v = iterative_hash_expr (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), v); + inchash::add_expr (TYPE_MAX_VALUE (TYPE_DOMAIN (type)), hstate); } /* Recurse for aggregates with a single element type. */ if (TREE_CODE (type) == ARRAY_TYPE || TREE_CODE (type) == COMPLEX_TYPE || TREE_CODE (type) == VECTOR_TYPE) - v = iterative_hash_canonical_type (TREE_TYPE (type), v); + iterative_hash_canonical_type (TREE_TYPE (type), hstate); /* Incorporate function return and argument types. */ if (TREE_CODE (type) == FUNCTION_TYPE || TREE_CODE (type) == METHOD_TYPE) @@ -345,17 +346,17 @@ hash_canonical_type (tree type) /* For method types also incorporate their parent class. */ if (TREE_CODE (type) == METHOD_TYPE) - v = iterative_hash_canonical_type (TYPE_METHOD_BASETYPE (type), v); + iterative_hash_canonical_type (TYPE_METHOD_BASETYPE (type), hstate); - v = iterative_hash_canonical_type (TREE_TYPE (type), v); + iterative_hash_canonical_type (TREE_TYPE (type), hstate); for (p = TYPE_ARG_TYPES (type), na = 0; p; p = TREE_CHAIN (p)) { - v = iterative_hash_canonical_type (TREE_VALUE (p), v); + iterative_hash_canonical_type (TREE_VALUE (p), hstate); na++; } - v = iterative_hash_hashval_t (na, v); + hstate.add_int (na); } if (RECORD_OR_UNION_TYPE_P (type)) @@ -366,20 +367,20 @@ hash_canonical_type (tree type) for (f = TYPE_FIELDS (type), nf = 0; f; f = TREE_CHAIN (f)) if (TREE_CODE (f) == FIELD_DECL) { - v = iterative_hash_canonical_type (TREE_TYPE (f), v); + iterative_hash_canonical_type (TREE_TYPE (f), hstate); nf++; } - v = iterative_hash_hashval_t (nf, v); + hstate.add_int (nf); } - return v; + return hstate.end(); } /* Returning a hash value for gimple type TYPE combined with VAL. */ -static hashval_t -iterative_hash_canonical_type (tree type, hashval_t val) +static void +iterative_hash_canonical_type (tree type, inchash::hash &hstate) { hashval_t v; /* An already processed type. */ @@ -397,7 +398,7 @@ iterative_hash_canonical_type (tree type, hashval_t val) v = hash_canonical_type (type); gimple_register_canonical_type_1 (type, v); } - return iterative_hash_hashval_t (v, val); + hstate.add_int (v); } /* Returns the hash for a canonical type P. */ diff --git a/main/gcc/omp-low.c b/main/gcc/omp-low.c index b46693b48dc..0fe2a402d55 100644 --- a/main/gcc/omp-low.c +++ b/main/gcc/omp-low.c @@ -812,16 +812,14 @@ is_reference (tree decl) static inline tree lookup_decl (tree var, omp_context *ctx) { - tree *n; - n = (tree *) pointer_map_contains (ctx->cb.decl_map, var); + tree *n = ctx->cb.decl_map->get (var); return *n; } static inline tree maybe_lookup_decl (const_tree var, omp_context *ctx) { - tree *n; - n = (tree *) pointer_map_contains (ctx->cb.decl_map, var); + tree *n = ctx->cb.decl_map->get (const_cast (var)); return n ? *n : NULL_TREE; } @@ -1359,7 +1357,7 @@ new_omp_context (gimple stmt, omp_context *outer_ctx) ctx->depth = 1; } - ctx->cb.decl_map = pointer_map_create (); + ctx->cb.decl_map = new hash_map; return ctx; } @@ -1408,7 +1406,7 @@ delete_omp_context (splay_tree_value value) { omp_context *ctx = (omp_context *) value; - pointer_map_destroy (ctx->cb.decl_map); + delete ctx->cb.decl_map; if (ctx->field_map) splay_tree_delete (ctx->field_map); @@ -6541,7 +6539,6 @@ expand_omp_for_static_chunk (struct omp_region *region, gimple_stmt_iterator psi; gimple phi; edge re, ene; - edge_var_map_vector *head; edge_var_map *vm; size_t i; @@ -6552,7 +6549,7 @@ expand_omp_for_static_chunk (struct omp_region *region, appropriate phi nodes in iter_part_bb instead. */ se = single_pred_edge (fin_bb); re = single_succ_edge (trip_update_bb); - head = redirect_edge_var_map_vector (re); + vec *head = redirect_edge_var_map_vector (re); ene = single_succ_edge (entry_bb); psi = gsi_start_phis (fin_bb); @@ -9219,7 +9216,7 @@ task_copyfn_remap_type (struct omp_taskcopy_context *tcctx, tree orig_type) walk_tree (&DECL_FIELD_OFFSET (new_f), copy_tree_body_r, &tcctx->cb, NULL); new_fields = new_f; - *pointer_map_insert (tcctx->cb.decl_map, f) = new_f; + tcctx->cb.decl_map->put (f, new_f); } TYPE_FIELDS (type) = nreverse (new_fields); layout_type (type); @@ -9286,7 +9283,7 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) tcctx.cb.copy_decl = task_copyfn_copy_decl; tcctx.cb.eh_lp_nr = 0; tcctx.cb.transform_call_graph_edges = CB_CGE_MOVE; - tcctx.cb.decl_map = pointer_map_create (); + tcctx.cb.decl_map = new hash_map; tcctx.ctx = ctx; if (record_needs_remap) @@ -9311,12 +9308,12 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) tree *p; decl = OMP_CLAUSE_DECL (c); - p = (tree *) pointer_map_contains (tcctx.cb.decl_map, decl); + p = tcctx.cb.decl_map->get (decl); if (p == NULL) continue; n = splay_tree_lookup (ctx->sfield_map, (splay_tree_key) decl); sf = (tree) n->value; - sf = *(tree *) pointer_map_contains (tcctx.cb.decl_map, sf); + sf = *tcctx.cb.decl_map->get (sf); src = build_simple_mem_ref_loc (loc, sarg); src = omp_build_component_ref (src, sf); t = build2 (MODIFY_EXPR, TREE_TYPE (*p), *p, src); @@ -9335,11 +9332,11 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) break; f = (tree) n->value; if (tcctx.cb.decl_map) - f = *(tree *) pointer_map_contains (tcctx.cb.decl_map, f); + f = *tcctx.cb.decl_map->get (f); n = splay_tree_lookup (ctx->sfield_map, (splay_tree_key) decl); sf = (tree) n->value; if (tcctx.cb.decl_map) - sf = *(tree *) pointer_map_contains (tcctx.cb.decl_map, sf); + sf = *tcctx.cb.decl_map->get (sf); src = build_simple_mem_ref_loc (loc, sarg); src = omp_build_component_ref (src, sf); dst = build_simple_mem_ref_loc (loc, arg); @@ -9356,13 +9353,13 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) break; f = (tree) n->value; if (tcctx.cb.decl_map) - f = *(tree *) pointer_map_contains (tcctx.cb.decl_map, f); + f = *tcctx.cb.decl_map->get (f); n = splay_tree_lookup (ctx->sfield_map, (splay_tree_key) decl); if (n != NULL) { sf = (tree) n->value; if (tcctx.cb.decl_map) - sf = *(tree *) pointer_map_contains (tcctx.cb.decl_map, sf); + sf = *tcctx.cb.decl_map->get (sf); src = build_simple_mem_ref_loc (loc, sarg); src = omp_build_component_ref (src, sf); if (use_pointer_for_field (decl, NULL) || is_reference (decl)) @@ -9382,13 +9379,13 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) n = splay_tree_lookup (ctx->field_map, (splay_tree_key) decl); f = (tree) n->value; if (tcctx.cb.decl_map) - f = *(tree *) pointer_map_contains (tcctx.cb.decl_map, f); + f = *tcctx.cb.decl_map->get (f); n = splay_tree_lookup (ctx->sfield_map, (splay_tree_key) decl); if (n != NULL) { sf = (tree) n->value; if (tcctx.cb.decl_map) - sf = *(tree *) pointer_map_contains (tcctx.cb.decl_map, sf); + sf = *tcctx.cb.decl_map->get (sf); src = build_simple_mem_ref_loc (loc, sarg); src = omp_build_component_ref (src, sf); if (use_pointer_for_field (decl, NULL)) @@ -9419,7 +9416,7 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) if (n == NULL) continue; f = (tree) n->value; - f = *(tree *) pointer_map_contains (tcctx.cb.decl_map, f); + f = *tcctx.cb.decl_map->get (f); gcc_assert (DECL_HAS_VALUE_EXPR_P (decl)); ind = DECL_VALUE_EXPR (decl); gcc_assert (TREE_CODE (ind) == INDIRECT_REF); @@ -9427,7 +9424,7 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) n = splay_tree_lookup (ctx->sfield_map, (splay_tree_key) TREE_OPERAND (ind, 0)); sf = (tree) n->value; - sf = *(tree *) pointer_map_contains (tcctx.cb.decl_map, sf); + sf = *tcctx.cb.decl_map->get (sf); src = build_simple_mem_ref_loc (loc, sarg); src = omp_build_component_ref (src, sf); src = build_simple_mem_ref_loc (loc, src); @@ -9438,7 +9435,7 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) n = splay_tree_lookup (ctx->field_map, (splay_tree_key) TREE_OPERAND (ind, 0)); df = (tree) n->value; - df = *(tree *) pointer_map_contains (tcctx.cb.decl_map, df); + df = *tcctx.cb.decl_map->get (df); ptr = build_simple_mem_ref_loc (loc, arg); ptr = omp_build_component_ref (ptr, df); t = build2 (MODIFY_EXPR, TREE_TYPE (ptr), ptr, @@ -9450,7 +9447,7 @@ create_task_copyfn (gimple task_stmt, omp_context *ctx) append_to_statement_list (t, &list); if (tcctx.cb.decl_map) - pointer_map_destroy (tcctx.cb.decl_map); + delete tcctx.cb.decl_map; pop_gimplify_context (NULL); BIND_EXPR_BODY (bind) = list; pop_cfun (); diff --git a/main/gcc/optabs.c b/main/gcc/optabs.c index 7ee84c4348c..65328a668ba 100644 --- a/main/gcc/optabs.c +++ b/main/gcc/optabs.c @@ -5559,13 +5559,17 @@ gen_int_libfunc (optab optable, const char *opname, char suffix, enum machine_mode mode) { int maxsize = 2 * BITS_PER_WORD; + int minsize = BITS_PER_WORD; if (GET_MODE_CLASS (mode) != MODE_INT) return; if (maxsize < LONG_LONG_TYPE_SIZE) maxsize = LONG_LONG_TYPE_SIZE; - if (GET_MODE_CLASS (mode) != MODE_INT - || GET_MODE_BITSIZE (mode) < BITS_PER_WORD + if (minsize > INT_TYPE_SIZE + && (trapv_binoptab_p (optable) + || trapv_unoptab_p (optable))) + minsize = INT_TYPE_SIZE; + if (GET_MODE_BITSIZE (mode) < minsize || GET_MODE_BITSIZE (mode) > maxsize) return; gen_libfunc (optable, opname, suffix, mode); @@ -7352,7 +7356,10 @@ expand_atomic_test_and_set (rtx target, rtx mem, enum memmodel model) perform the operation. */ if (!ret) { - emit_move_insn (subtarget, mem); + /* If the result is ignored skip the move to target. */ + if (subtarget != const0_rtx) + emit_move_insn (subtarget, mem); + emit_move_insn (mem, trueval); ret = subtarget; } diff --git a/main/gcc/opts.c b/main/gcc/opts.c index 18e3e5aa1ba..1efcd82628c 100644 --- a/main/gcc/opts.c +++ b/main/gcc/opts.c @@ -908,6 +908,20 @@ finish_options (struct gcc_options *opts, struct gcc_options *opts_set, set_debug_level (NO_DEBUG, DEFAULT_GDB_EXTENSIONS, "0", opts, opts_set, loc); } + + /* Userspace and kernel ASan conflict with each other and with TSan. */ + + if ((flag_sanitize & SANITIZE_USER_ADDRESS) + && (flag_sanitize & SANITIZE_KERNEL_ADDRESS)) + error_at (loc, + "-fsanitize=address is incompatible with " + "-fsanitize=kernel-address"); + + if ((flag_sanitize & SANITIZE_ADDRESS) + && (flag_sanitize & SANITIZE_THREAD)) + error_at (loc, + "-fsanitize=address and -fsanitize=kernel-address " + "are incompatible with -fsanitize=thread"); } #define LEFT_COLUMN 27 @@ -1494,7 +1508,10 @@ common_handle_option (struct gcc_options *opts, size_t len; } spec[] = { - { "address", SANITIZE_ADDRESS, sizeof "address" - 1 }, + { "address", SANITIZE_ADDRESS | SANITIZE_USER_ADDRESS, + sizeof "address" - 1 }, + { "kernel-address", SANITIZE_ADDRESS | SANITIZE_KERNEL_ADDRESS, + sizeof "kernel-address" - 1 }, { "thread", SANITIZE_THREAD, sizeof "thread" - 1 }, { "leak", SANITIZE_LEAK, sizeof "leak" - 1 }, { "shift", SANITIZE_SHIFT, sizeof "shift" - 1 }, @@ -1515,6 +1532,7 @@ common_handle_option (struct gcc_options *opts, { "float-cast-overflow", SANITIZE_FLOAT_CAST, sizeof "float-cast-overflow" - 1 }, { "bounds", SANITIZE_BOUNDS, sizeof "bounds" - 1 }, + { "alignment", SANITIZE_ALIGNMENT, sizeof "alignment" - 1 }, { NULL, 0, 0 } }; const char *comma; @@ -1560,6 +1578,25 @@ common_handle_option (struct gcc_options *opts, the null pointer checks. */ if (flag_sanitize & SANITIZE_NULL) opts->x_flag_delete_null_pointer_checks = 0; + + /* Kernel ASan implies normal ASan but does not yet support + all features. */ + if (flag_sanitize & SANITIZE_KERNEL_ADDRESS) + { + maybe_set_param_value (PARAM_ASAN_INSTRUMENTATION_WITH_CALL_THRESHOLD, 0, + opts->x_param_values, + opts_set->x_param_values); + maybe_set_param_value (PARAM_ASAN_GLOBALS, 0, + opts->x_param_values, + opts_set->x_param_values); + maybe_set_param_value (PARAM_ASAN_STACK, 0, + opts->x_param_values, + opts_set->x_param_values); + maybe_set_param_value (PARAM_ASAN_USE_AFTER_RETURN, 0, + opts->x_param_values, + opts_set->x_param_values); + } + break; } diff --git a/main/gcc/params.def b/main/gcc/params.def index c6f35282d69..fe73f36895d 100644 --- a/main/gcc/params.def +++ b/main/gcc/params.def @@ -1091,6 +1091,14 @@ DEFPARAM (PARAM_GCOV_DEBUG, "Looking for gcda file in current dir.", 0, 0, 1) +/* When the parameter is 1, use the internal function id + to look up for profile data. Otherwise, use a more stable + external id based on assembler name and source location. */ +DEFPARAM (PARAM_PROFILE_FUNC_INTERNAL_ID, + "profile-func-internal-id", + "use internal function id in profile lookup", + 0, 0, 1) + /* Avoid SLP vectorization of large basic blocks. */ DEFPARAM (PARAM_SLP_MAX_INSNS_IN_BB, "slp-max-insns-in-bb", diff --git a/main/gcc/passes.c b/main/gcc/passes.c index 608755cc008..eb9a4b33152 100644 --- a/main/gcc/passes.c +++ b/main/gcc/passes.c @@ -1492,7 +1492,7 @@ do_per_function (void (*callback) (function *, void *data), void *data) { struct cgraph_node *node; FOR_EACH_DEFINED_FUNCTION (node) - if (node->analyzed && gimple_has_body_p (node->decl) + if (node->analyzed && (gimple_has_body_p (node->decl) && !in_lto_p) && (!node->clone_of || node->decl != node->clone_of->decl)) callback (DECL_STRUCT_FUNCTION (node->decl), data); } diff --git a/main/gcc/predict.c b/main/gcc/predict.c index 2eed332ba92..8929fb64a13 100644 --- a/main/gcc/predict.c +++ b/main/gcc/predict.c @@ -52,6 +52,7 @@ along with GCC; see the file COPYING3. If not see #include "target.h" #include "cfgloop.h" #include "pointer-set.h" +#include "hash-map.h" #include "tree-ssa-alias.h" #include "internal-fn.h" #include "gimple-expr.h" @@ -492,11 +493,6 @@ rtl_predicted_by_p (const_basic_block bb, enum br_predictor predictor) return false; } -/* This map contains for a basic block the list of predictions for the - outgoing edges. */ - -static struct pointer_map_t *bb_predictions; - /* Structure representing predictions in tree level. */ struct edge_prediction { @@ -506,6 +502,11 @@ struct edge_prediction { int ep_probability; }; +/* This map contains for a basic block the list of predictions for the + outgoing edges. */ + +static hash_map *bb_predictions; + /* Return true if the one of outgoing edges is already predicted by PREDICTOR. */ @@ -513,12 +514,12 @@ bool gimple_predicted_by_p (const_basic_block bb, enum br_predictor predictor) { struct edge_prediction *i; - void **preds = pointer_map_contains (bb_predictions, bb); + edge_prediction **preds = bb_predictions->get (bb); if (!preds) return false; - for (i = (struct edge_prediction *) *preds; i; i = i->ep_next) + for (i = *preds; i; i = i->ep_next) if (i->ep_predictor == predictor) return true; return false; @@ -620,10 +621,10 @@ gimple_predict_edge (edge e, enum br_predictor predictor, int probability) && flag_guess_branch_prob && optimize) { struct edge_prediction *i = XNEW (struct edge_prediction); - void **preds = pointer_map_insert (bb_predictions, e->src); + edge_prediction *&preds = bb_predictions->get_or_insert (e->src); - i->ep_next = (struct edge_prediction *) *preds; - *preds = i; + i->ep_next = preds; + preds = i; i->ep_probability = probability; i->ep_predictor = predictor; i->ep_edge = e; @@ -635,16 +636,14 @@ gimple_predict_edge (edge e, enum br_predictor predictor, int probability) void remove_predictions_associated_with_edge (edge e) { - void **preds; - if (!bb_predictions) return; - preds = pointer_map_contains (bb_predictions, e->src); + edge_prediction **preds = bb_predictions->get (e->src); if (preds) { - struct edge_prediction **prediction = (struct edge_prediction **) preds; + struct edge_prediction **prediction = preds; struct edge_prediction *next; while (*prediction) @@ -666,13 +665,13 @@ remove_predictions_associated_with_edge (edge e) static void clear_bb_predictions (basic_block bb) { - void **preds = pointer_map_contains (bb_predictions, bb); + edge_prediction **preds = bb_predictions->get (bb); struct edge_prediction *pred, *next; if (!preds) return; - for (pred = (struct edge_prediction *) *preds; pred; pred = next) + for (pred = *preds; pred; pred = next) { next = pred->ep_next; free (pred); @@ -905,7 +904,6 @@ combine_predictions_for_bb (basic_block bb) int nedges = 0; edge e, first = NULL, second = NULL; edge_iterator ei; - void **preds; FOR_EACH_EDGE (e, ei, bb->succs) if (!(e->flags & (EDGE_EH | EDGE_FAKE))) @@ -937,12 +935,12 @@ combine_predictions_for_bb (basic_block bb) if (dump_file) fprintf (dump_file, "Predictions for bb %i\n", bb->index); - preds = pointer_map_contains (bb_predictions, bb); + edge_prediction **preds = bb_predictions->get (bb); if (preds) { /* We implement "first match" heuristics and use probability guessed by predictor with smallest index. */ - for (pred = (struct edge_prediction *) *preds; pred; pred = pred->ep_next) + for (pred = *preds; pred; pred = pred->ep_next) { enum br_predictor predictor = pred->ep_predictor; int probability = pred->ep_probability; @@ -2245,14 +2243,14 @@ tree_bb_level_predictions (void) #ifdef ENABLE_CHECKING -/* Callback for pointer_map_traverse, asserts that the pointer map is +/* Callback for hash_map::traverse, asserts that the pointer map is empty. */ -static bool -assert_is_empty (const void *key ATTRIBUTE_UNUSED, void **value, - void *data ATTRIBUTE_UNUSED) +bool +assert_is_empty (const_basic_block const &, edge_prediction *const &value, + void *) { - gcc_assert (!*value); + gcc_assert (!value); return false; } #endif @@ -2377,7 +2375,7 @@ tree_estimate_probability (void) create_preheaders (CP_SIMPLE_PREHEADERS); calculate_dominance_info (CDI_POST_DOMINATORS); - bb_predictions = pointer_map_create (); + bb_predictions = new hash_map; tree_bb_level_predictions (); record_loop_exits (); @@ -2391,9 +2389,9 @@ tree_estimate_probability (void) combine_predictions_for_bb (bb); #ifdef ENABLE_CHECKING - pointer_map_traverse (bb_predictions, assert_is_empty, NULL); + bb_predictions->traverse (NULL); #endif - pointer_map_destroy (bb_predictions); + delete bb_predictions; bb_predictions = NULL; estimate_bb_frequencies (false); diff --git a/main/gcc/reginfo.c b/main/gcc/reginfo.c index 5bf07f6c4dc..7668be02dcd 100644 --- a/main/gcc/reginfo.c +++ b/main/gcc/reginfo.c @@ -533,8 +533,11 @@ reinit_regs (void) init_regs (); /* caller_save needs to be re-initialized. */ caller_save_initialized_p = false; - ira_init (); - recog_init (); + if (this_target_rtl->target_specific_initialized) + { + ira_init (); + recog_init (); + } } /* Initialize some fake stack-frame MEM references for use in diff --git a/main/gcc/rtl.c b/main/gcc/rtl.c index 520f9a8eb7f..3363eebdbb6 100644 --- a/main/gcc/rtl.c +++ b/main/gcc/rtl.c @@ -33,6 +33,7 @@ along with GCC; see the file COPYING3. If not see #ifdef GENERATOR_FILE # include "errors.h" #else +# include "rtlhash.h" # include "diagnostic-core.h" #endif @@ -654,84 +655,6 @@ rtx_equal_p (const_rtx x, const_rtx y) return 1; } -/* Iteratively hash rtx X. */ - -hashval_t -iterative_hash_rtx (const_rtx x, hashval_t hash) -{ - enum rtx_code code; - enum machine_mode mode; - int i, j; - const char *fmt; - - if (x == NULL_RTX) - return hash; - code = GET_CODE (x); - hash = iterative_hash_object (code, hash); - mode = GET_MODE (x); - hash = iterative_hash_object (mode, hash); - switch (code) - { - case REG: - i = REGNO (x); - return iterative_hash_object (i, hash); - case CONST_INT: - return iterative_hash_object (INTVAL (x), hash); - case CONST_WIDE_INT: - for (i = 0; i < CONST_WIDE_INT_NUNITS (x); i++) - hash = iterative_hash_object (CONST_WIDE_INT_ELT (x, i), hash); - return hash; - case SYMBOL_REF: - if (XSTR (x, 0)) - return iterative_hash (XSTR (x, 0), strlen (XSTR (x, 0)) + 1, - hash); - return hash; - case LABEL_REF: - case DEBUG_EXPR: - case VALUE: - case SCRATCH: - case CONST_DOUBLE: - case CONST_FIXED: - case DEBUG_IMPLICIT_PTR: - case DEBUG_PARAMETER_REF: - return hash; - default: - break; - } - - fmt = GET_RTX_FORMAT (code); - for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) - switch (fmt[i]) - { - case 'w': - hash = iterative_hash_object (XWINT (x, i), hash); - break; - case 'n': - case 'i': - hash = iterative_hash_object (XINT (x, i), hash); - break; - case 'V': - case 'E': - j = XVECLEN (x, i); - hash = iterative_hash_object (j, hash); - for (j = 0; j < XVECLEN (x, i); j++) - hash = iterative_hash_rtx (XVECEXP (x, i, j), hash); - break; - case 'e': - hash = iterative_hash_rtx (XEXP (x, i), hash); - break; - case 'S': - case 's': - if (XSTR (x, i)) - hash = iterative_hash (XSTR (x, 0), strlen (XSTR (x, 0)) + 1, - hash); - break; - default: - break; - } - return hash; -} - void dump_rtx_statistics (void) { diff --git a/main/gcc/rtl.h b/main/gcc/rtl.h index 8eb215cbaa1..2fb0c5c4f68 100644 --- a/main/gcc/rtl.h +++ b/main/gcc/rtl.h @@ -1983,7 +1983,6 @@ extern unsigned int rtx_size (const_rtx); extern rtx shallow_copy_rtx_stat (const_rtx MEM_STAT_DECL); #define shallow_copy_rtx(a) shallow_copy_rtx_stat (a MEM_STAT_INFO) extern int rtx_equal_p (const_rtx, const_rtx); -extern hashval_t iterative_hash_rtx (const_rtx, hashval_t); /* In emit-rtl.c */ extern rtvec gen_rtvec_v (int, rtx *); @@ -2292,6 +2291,7 @@ extern int replace_label (rtx *, void *); extern int rtx_referenced_p (rtx, rtx); extern bool tablejump_p (const_rtx, rtx *, rtx *); extern int computed_jump_p (const_rtx); +extern bool tls_referenced_p (rtx); typedef int (*rtx_function) (rtx *, void *); extern int for_each_rtx (rtx *, rtx_function, void *); @@ -2517,7 +2517,6 @@ struct GTY(()) target_rtl { /* Track if RTL has been initialized. */ bool target_specific_initialized; - bool lang_dependent_initialized; }; extern GTY(()) struct target_rtl default_target_rtl; diff --git a/main/gcc/rtlanal.c b/main/gcc/rtlanal.c index 82cfc1bf70b..c513ec1a796 100644 --- a/main/gcc/rtlanal.c +++ b/main/gcc/rtlanal.c @@ -5960,3 +5960,22 @@ get_index_code (const struct address_info *info) return SCRATCH; } + +/* Return 1 if *X is a thread-local symbol. */ + +static int +tls_referenced_p_1 (rtx *x, void *) +{ + return GET_CODE (*x) == SYMBOL_REF && SYMBOL_REF_TLS_MODEL (*x) != 0; +} + +/* Return true if X contains a thread-local symbol. */ + +bool +tls_referenced_p (rtx x) +{ + if (!targetm.have_tls) + return false; + + return for_each_rtx (&x, &tls_referenced_p_1, 0); +} diff --git a/main/gcc/rtlhash.c b/main/gcc/rtlhash.c new file mode 100644 index 00000000000..ed4ee7a74b5 --- /dev/null +++ b/main/gcc/rtlhash.c @@ -0,0 +1,107 @@ +/* RTL hash functions. + Copyright (C) 1987-2014 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" +#include "ggc.h" +#include "rtl.h" +#include "rtlhash.h" + +namespace inchash +{ + +/* Iteratively hash rtx X into HSTATE. */ + +void +add_rtx (const_rtx x, hash &hstate) +{ + enum rtx_code code; + enum machine_mode mode; + int i, j; + const char *fmt; + + if (x == NULL_RTX) + return; + code = GET_CODE (x); + hstate.add_object (code); + mode = GET_MODE (x); + hstate.add_object (mode); + switch (code) + { + case REG: + hstate.add_int (REGNO (x)); + return; + case CONST_INT: + hstate.add_object (INTVAL (x)); + return; + case CONST_WIDE_INT: + for (i = 0; i < CONST_WIDE_INT_NUNITS (x); i++) + hstate.add_object (CONST_WIDE_INT_ELT (x, i)); + return; + case SYMBOL_REF: + if (XSTR (x, 0)) + hstate.add (XSTR (x, 0), strlen (XSTR (x, 0)) + 1); + return; + case LABEL_REF: + case DEBUG_EXPR: + case VALUE: + case SCRATCH: + case CONST_DOUBLE: + case CONST_FIXED: + case DEBUG_IMPLICIT_PTR: + case DEBUG_PARAMETER_REF: + return; + default: + break; + } + + fmt = GET_RTX_FORMAT (code); + for (i = GET_RTX_LENGTH (code) - 1; i >= 0; i--) + switch (fmt[i]) + { + case 'w': + hstate.add_object (XWINT (x, i)); + break; + case 'n': + case 'i': + hstate.add_object (XINT (x, i)); + break; + case 'V': + case 'E': + j = XVECLEN (x, i); + hstate.add_int (j); + for (j = 0; j < XVECLEN (x, i); j++) + inchash::add_rtx (XVECEXP (x, i, j), hstate); + break; + case 'e': + inchash::add_rtx (XEXP (x, i), hstate); + break; + case 'S': + case 's': + if (XSTR (x, i)) + hstate.add (XSTR (x, 0), strlen (XSTR (x, 0)) + 1); + break; + default: + break; + } +} + +} diff --git a/main/gcc/lto/lto-partition.h b/main/gcc/rtlhash.h similarity index 52% copy from main/gcc/lto/lto-partition.h copy to main/gcc/rtlhash.h index 8db61b30176..158a2c2563b 100644 --- a/main/gcc/lto/lto-partition.h +++ b/main/gcc/rtlhash.h @@ -1,5 +1,5 @@ -/* LTO partitioning logic routines. - Copyright (C) 2009-2014 Free Software Foundation, Inc. +/* Register Transfer Language (RTL) hash functions. + Copyright (C) 1987-2014 Free Software Foundation, Inc. This file is part of GCC. @@ -17,24 +17,16 @@ You should have received a copy of the GNU General Public License along with GCC; see the file COPYING3. If not see . */ +#ifndef RTL_HASH_H +#define RTL_HASH_H 1 -/* Structure describing ltrans partitions. */ +#include "inchash.h" -struct ltrans_partition_def +namespace inchash { - lto_symtab_encoder_t encoder; - const char * name; - int insns; - pointer_set_t *initializers_visited; -}; - -typedef struct ltrans_partition_def *ltrans_partition; - -extern vec ltrans_partitions; - -void lto_1_to_1_map (void); -void lto_max_map (void); -void lto_balanced_map (int); -void lto_promote_cross_file_statics (void); -void free_ltrans_partitions (void); -void lto_promote_statics_nonwpa (void); + +extern void add_rtx (const_rtx, hash &); + +} + +#endif diff --git a/main/gcc/sched-deps.c b/main/gcc/sched-deps.c index d2715213962..51c1a011496 100644 --- a/main/gcc/sched-deps.c +++ b/main/gcc/sched-deps.c @@ -2821,35 +2821,42 @@ sched_analyze_2 (struct deps_desc *deps, rtx x, rtx insn) sched_deps_info->finish_rhs (); } -/* Try to group comparison and the following conditional jump INSN if - they're already adjacent. This is to prevent scheduler from scheduling - them apart. */ +/* Try to group two fuseable insns together to prevent scheduler + from scheduling them apart. */ static void -try_group_insn (rtx insn) +sched_macro_fuse_insns (rtx insn) { - unsigned int condreg1, condreg2; - rtx cc_reg_1; rtx prev; - if (!any_condjump_p (insn)) - return; + if (any_condjump_p (insn)) + { + unsigned int condreg1, condreg2; + rtx cc_reg_1; + targetm.fixed_condition_code_regs (&condreg1, &condreg2); + cc_reg_1 = gen_rtx_REG (CCmode, condreg1); + prev = prev_nonnote_nondebug_insn (insn); + if (!reg_referenced_p (cc_reg_1, PATTERN (insn)) + || !prev + || !modified_in_p (cc_reg_1, prev)) + return; + } + else + { + rtx insn_set = single_set (insn); - targetm.fixed_condition_code_regs (&condreg1, &condreg2); - cc_reg_1 = gen_rtx_REG (CCmode, condreg1); - prev = prev_nonnote_nondebug_insn (insn); - if (!reg_referenced_p (cc_reg_1, PATTERN (insn)) - || !prev - || !modified_in_p (cc_reg_1, prev)) - return; + prev = prev_nonnote_nondebug_insn (insn); + if (!prev + || !insn_set + || !single_set (prev) + || !modified_in_p (SET_DEST (insn_set), prev)) + return; - /* Different microarchitectures support macro fusions for different - combinations of insn pairs. */ - if (!targetm.sched.macro_fusion_pair_p - || !targetm.sched.macro_fusion_pair_p (prev, insn)) - return; + } + + if (targetm.sched.macro_fusion_pair_p (prev, insn)) + SCHED_GROUP_P (insn) = 1; - SCHED_GROUP_P (insn) = 1; } /* Analyze an INSN with pattern X to find all dependencies. */ @@ -2878,7 +2885,7 @@ sched_analyze_insn (struct deps_desc *deps, rtx x, rtx insn) /* Group compare and branch insns for macro-fusion. */ if (targetm.sched.macro_fusion_p && targetm.sched.macro_fusion_p ()) - try_group_insn (insn); + sched_macro_fuse_insns (insn); if (may_trap_p (x)) /* Avoid moving trapping instructions across function calls that might diff --git a/main/gcc/simplify-rtx.c b/main/gcc/simplify-rtx.c index 07b93538969..9f6dbe119c6 100644 --- a/main/gcc/simplify-rtx.c +++ b/main/gcc/simplify-rtx.c @@ -3368,6 +3368,50 @@ simplify_binary_operation_1 (enum rtx_code code, enum machine_mode mode, return simplify_gen_binary (VEC_CONCAT, mode, subop0, subop1); } + + /* If we select one half of a vec_concat, return that. */ + if (GET_CODE (trueop0) == VEC_CONCAT + && CONST_INT_P (XVECEXP (trueop1, 0, 0))) + { + rtx subop0 = XEXP (trueop0, 0); + rtx subop1 = XEXP (trueop0, 1); + enum machine_mode mode0 = GET_MODE (subop0); + enum machine_mode mode1 = GET_MODE (subop1); + int li = GET_MODE_SIZE (GET_MODE_INNER (mode0)); + int l0 = GET_MODE_SIZE (mode0) / li; + int l1 = GET_MODE_SIZE (mode1) / li; + int i0 = INTVAL (XVECEXP (trueop1, 0, 0)); + if (i0 == 0 && !side_effects_p (op1) && mode == mode0) + { + bool success = true; + for (int i = 1; i < l0; ++i) + { + rtx j = XVECEXP (trueop1, 0, i); + if (!CONST_INT_P (j) || INTVAL (j) != i) + { + success = false; + break; + } + } + if (success) + return subop0; + } + if (i0 == l0 && !side_effects_p (op0) && mode == mode1) + { + bool success = true; + for (int i = 1; i < l1; ++i) + { + rtx j = XVECEXP (trueop1, 0, i); + if (!CONST_INT_P (j) || INTVAL (j) != i0 + i) + { + success = false; + break; + } + } + if (success) + return subop1; + } + } } if (XVECLEN (trueop1, 0) == 1 diff --git a/main/gcc/stmt.c b/main/gcc/stmt.c index bd4da373c62..b08210c3e89 100644 --- a/main/gcc/stmt.c +++ b/main/gcc/stmt.c @@ -47,6 +47,7 @@ along with GCC; see the file COPYING3. If not see #include "predict.h" #include "optabs.h" #include "target.h" +#include "hash-set.h" #include "pointer-set.h" #include "basic-block.h" #include "tree-ssa-alias.h" @@ -1185,7 +1186,7 @@ expand_case (gimple stmt) how to expand this switch(). */ uniq = 0; count = 0; - struct pointer_set_t *seen_labels = pointer_set_create (); + hash_set seen_labels; compute_cases_per_edge (stmt); for (i = ncases - 1; i >= 1; --i) @@ -1205,7 +1206,7 @@ expand_case (gimple stmt) /* If we have not seen this label yet, then increase the number of unique case node targets seen. */ - if (!pointer_set_insert (seen_labels, lab)) + if (!seen_labels.add (lab)) uniq++; /* The bounds on the case range, LOW and HIGH, have to be converted @@ -1233,7 +1234,6 @@ expand_case (gimple stmt) case_edge->probability / (intptr_t)(case_edge->aux), case_node_pool); } - pointer_set_destroy (seen_labels); reset_out_edges_aux (bb); /* cleanup_tree_cfg removes all SWITCH_EXPR with a single diff --git a/main/gcc/stor-layout.c b/main/gcc/stor-layout.c index 109264b2ff0..1c65490ae77 100644 --- a/main/gcc/stor-layout.c +++ b/main/gcc/stor-layout.c @@ -2390,6 +2390,27 @@ layout_type (tree type) gcc_assert (!TYPE_ALIAS_SET_KNOWN_P (type)); } +/* Return the least alignment required for type TYPE. */ + +unsigned int +min_align_of_type (tree type) +{ + unsigned int align = TYPE_ALIGN (type); + align = MIN (align, BIGGEST_ALIGNMENT); +#ifdef BIGGEST_FIELD_ALIGNMENT + align = MIN (align, BIGGEST_FIELD_ALIGNMENT); +#endif + unsigned int field_align = align; +#ifdef ADJUST_FIELD_ALIGN + tree field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, NULL_TREE, + type); + field_align = ADJUST_FIELD_ALIGN (field, field_align); + ggc_free (field); +#endif + align = MIN (align, field_align); + return align / BITS_PER_UNIT; +} + /* Vector types need to re-check the target flags each time we report the machine mode. We need to do this because attribute target can change the result of vector_mode_supported_p and have_regs_of_mode diff --git a/main/gcc/stor-layout.h b/main/gcc/stor-layout.h index 0ff98f8f051..f7c52670a93 100644 --- a/main/gcc/stor-layout.h +++ b/main/gcc/stor-layout.h @@ -59,6 +59,9 @@ extern void layout_decl (tree, unsigned); node, does nothing except for the first time. */ extern void layout_type (tree); +/* Return the least alignment in bytes required for type TYPE. */ +extern unsigned int min_align_of_type (tree); + /* Construct various nodes representing fract or accum data types. */ extern tree make_fract_type (int, int, int); extern tree make_accum_type (int, int, int); diff --git a/main/gcc/testsuite/ChangeLog b/main/gcc/testsuite/ChangeLog index 1aeb7abd353..efbb94dccfe 100644 --- a/main/gcc/testsuite/ChangeLog +++ b/main/gcc/testsuite/ChangeLog @@ -1,3 +1,269 @@ +2014-08-04 Rohit + + PR target/60102 + * gcc.target/powerpc/pr60102.c: New testcase. + +2014-08-04 Kyrylo Tkachov + + PR target/61713 + * gcc.dg/pr61756.c: New test. + +2014-08-04 Tom de Vries + + * gcc.dg/cproj-fails-with-broken-glibc.c: Use xfail for broken glibc + version instead of required-target. + * lib/target-supports.exp + (check_effective_target_not_glibc_2_11_or_earlier): Replace by ... + (check_effective_target_glibc_2_11_or_earlier): ... this. + +2014-08-04 Arnaud Charlet + + * gnat.dg/discr6.adb, gnat.dg/discr6_pkg.ads: Removed, no longer + relevant. + * gnat.dg/debug1.ads: Adjust. + * gnat.dg/formal_type.ads: Fix error in test. + +2014-08-03 Marek Polacek + + * gcc.dg/case-bogus-1.c: New test. + +2014-08-02 Paolo Carlini + + PR c++/15339 + * g++.dg/other/default9.C: New. + * g++.dg/other/default10.C: Likewise. + * g++.dg/other/default3.C: Remove xfail. + +2014-08-02 Jan Hubicka + + * g++.dg/warn/Wsuggest-final.C: New testcase. + * g++.dg/ipa/devirt-34.C: Fix. + +2014-08-02 Marek Polacek + + PR c/59855 + * gcc.dg/Wdesignated-init-2.c: New test. + +2014-08-01 Paolo Carlini + + DR 217 again + * g++.dg/tc1/dr217-2.C: New. + +2014-08-01 Igor Zamyatin + + PR other/61963 + * c-c++-common/cilk-plus/AN/pr61963.c: New test. + +2014-07-08 Igor Zamyatin + + PR middle-end/61455 + * c-c++-common/cilk-plus/AN/pr61455.c: New test. + * c-c++-common/cilk-plus/AN/pr61455-2.c: Likewise. + +2014-08-01 Jiong Wang + + * gcc.target/aarch64/legitimize_stack_var_before_reload_1.c: New + testcase. + +2014-08-01 Richard Biener + + PR middle-end/61762 + * gcc.dg/pr61762.c: Align the string to make the testcase work + on strict-align targets. + +2014-08-01 Jakub Jelinek + + * c-c++-common/ubsan/align-1.c: New test. + * c-c++-common/ubsan/align-2.c: New test. + * c-c++-common/ubsan/align-3.c: New test. + * c-c++-common/ubsan/align-4.c: New test. + * c-c++-common/ubsan/align-5.c: New test. + * c-c++-common/ubsan/attrib-4.c: New test. + * g++.dg/ubsan/align-1.C: New test. + * g++.dg/ubsan/align-2.C: New test. + * g++.dg/ubsan/align-3.C: New test. + * g++.dg/ubsan/attrib-1.C: New test. + * g++.dg/ubsan/null-1.C: New test. + * g++.dg/ubsan/null-2.C: New test. + +2014-08-01 Tom de Vries + + * lib/target-supports.exp (check_effective_target_glibc) + (check_effective_target_glibc_2_12_or_later) + (check_effective_target_not_glibc_2_11_or_earlier): New proc. + * gcc.dg/cproj-fails-with-broken-glibc.c: Require effective target + not_glibc_2_11_or_earlier. + +2014-07-31 Tom de Vries + + * gcc.dg/pr51879-7.c: Remove superfluous declaration of bar. + +2014-07-31 James Greenhalgh + + * gcc.target/aarch64/scalar_intrinsics.c (test_vpaddd_f64): New. + (test_vpaddd_s64): Likewise. + (test_vpaddd_s64): Likewise. + * gcc.target/aarch64/simd/vpaddd_f64: New. + * gcc.target/aarch64/simd/vpaddd_s64: New. + * gcc.target/aarch64/simd/vpaddd_u64: New. + +2014-07-31 Charles Baylis + + PR target/61948 + * gcc.target/arm/pr61948.c: New test case. + +2014-07-31 Richard Biener + + PR tree-optimization/61964 + * gcc.dg/torture/pr61964.c: New testcase. + +2014-07-31 Marc Glisse + + PR c++/60517 + * c-c++-common/addrtmp.c: New file. + * c-c++-common/uninit-G.c: Adapt. + +2014-07-31 Bingfeng Mei + + PR lto/61868 + * gcc.dg/pr61868.c: New test. + +2014-07-30 Paolo Carlini + + PR c++/57397 + * g++.dg/cpp0x/vt-57397-1.C: New. + * g++.dg/cpp0x/vt-57397-2.C: Likewise. + +2014-07-30 Arnaud Charlet + + * gnat.dg/case_null.adb, gnat.dg/specs/debug1.ads: Adjust tests. + +2014-07-30 Tom Tromey + + PR c/59855 + * gcc.dg/Wdesignated-init.c: New file. + +2014-07-29 Jan Hubicka + + * g++.dg/ipa/devirt-34.C: New testcase. + +2014-07-28 Richard Biener + + PR rtl-optimization/61801 + * gcc.target/i386/pr61801.c: Fix testcase. + +2014-07-28 Eric Botcazou + + * gcc.dg/fold-abs-5.c: New test. + * gcc.dg/Wstrict-overflow-25.c: XFAIL everywhere. + * gcc.dg/fold-compare-8.c: Likewise. + +2014-07-28 Richard Biener + + PR middle-end/52478 + * gcc.dg/torture/ftrapv-1.c: New testcase. + +2014-07-28 Richard Biener + + PR tree-optimization/61921 + * gfortran.dg/pr61921.f90: New testcase. + +2014-07-28 Richard Biener + + PR rtl-optimization/61801 + * gcc.target/i386/pr61801.c: New testcase. + +2014-07-27 Marek Polacek + + PR c/61861 + * gcc.dg/pr61861.c: New test. + +2014-07-27 Petr Murzin + + * gcc.target/i386/avx512f-vbroadcastf64x4-2.c: Fix the uninitialized + variable problem. + +2014-07-27 Richard Sandiford + + PR rtl-optimization/61926 + * gcc.target/mips/const-anchor-1.c, gcc.target/mips/const-anchor-2.c: + Reverse argument order. + * gcc.target/mips/const-anchor-3.c, gcc.target/mips/const-anchor-4.c: + New XFAILed tests that match the original order. + +2014-07-26 Marek Polacek + + PR c/61077 + * gcc.dg/pr61077.c: Use \[^\n\]* instead of .* in the regexp. + +2014-07-26 Tobias Burnus + + PR fortran/61881 + PR fortran/61888 + PR fortran/57305 + * gfortran.dg/sizeof_2.f90: Change dg-error. + * gfortran.dg/sizeof_4.f90: New. + * gfortran.dg/storage_size_1.f08: Correct expected + value. + +2014-07-26 Marc Glisse + + PR target/44551 + * gcc.target/i386/pr44551-1.c: New file. + +2014-07-25 Xinliang David Li + + * g++.dg/tree-prof/tree-prof.exp: Define macros. + * g++.dg/tree-prof/reorder_class1.h: New file. + * g++.dg/tree-prof/reorder_class2.h: New file. + * g++.dg/tree-prof/reorder.C: New test. + * g++.dg/tree-prof/morefunc.C: New test. + +2014-07-25 Edward Smith-Rowland <3dw4rd@verizon.net> + + Implement N4051 - Allow typename in a template template parameter + * lib/target-supports.exp (check_effective_target_c++1y): Now + means C++1y and up. + (check_effective_target_c++1y_down): New. + (check_effective_target_c++1z_only): New. + (check_effective_target_c++1z): New. + * g++.dg/cpp1z/typename-tmpl-tmpl-parm.C: New. + * g++.dg/cpp1z/typename-tmpl-tmpl-parm-neg.C: New. + * g++.dg/cpp1z/typename-tmpl-tmpl-parm-.C: New. + +2014-07-25 Tobias Burnus + + * gfortran.dg/storage_size_5.f90: New. + +2014-07-25 Richard Biener + + PR middle-end/61762 + PR middle-end/61894 + * gcc.dg/pr61762.c: New testcase. + * gcc.dg/fold-cstring.c: Likewise. + * gcc.dg/fold-cvect.c: Likewise. + +2014-07-24 Ulrich Weigand + + * gcc.target/powerpc/ppc64-abi-warn-3.c: New test. + + * gcc.c-torture/execute/20050316-1.x: Add -Wno-psabi. + * gcc.c-torture/execute/20050604-1.x: Add -Wno-psabi. + * gcc.c-torture/execute/20050316-3.x: New file. Add -Wno-psabi. + * gcc.c-torture/execute/pr23135.x: Likewise. + +2014-07-24 Ulrich Weigand + + * gcc.target/powerpc/ppc64-abi-warn-2.c: New test. + +2014-07-24 Ulrich Weigand + + * gcc.target/powerpc/ppc64-abi-warn-1.c: New test. + +2014-07-24 Ulrich Weigand + + * g++.dg/compat/struct-layout-1.exp: Load g++-dg.exp. + 2014-07-24 Jiong Wang * gcc.target/aarch64/test_frame_1.c: Match optimized instruction diff --git a/main/gcc/testsuite/c-c++-common/addrtmp.c b/main/gcc/testsuite/c-c++-common/addrtmp.c new file mode 100644 index 00000000000..3b8140cf805 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/addrtmp.c @@ -0,0 +1,29 @@ +/* { dg-do compile } */ +/* { dg-options "-O2" } */ + +typedef struct A { int a,b; } A; +int*g(int*x){return x;} +int*f1(){ + A x[2]={{1,2},{3,4}}; + return g(&x[1].a); // { dg-warning "returns address of local variable" } +} +int*f2(int n){ + A x[2]={{1,2},{3,4}}; + return n?0:g(&x[1].a); // { dg-warning "may return address of local variable" } +} +A y[2]={{1,2},{3,4}}; +int*h(){ + return g(&y[1].a); +} +int*j(int n){ + A x[2]={{1,2},{3,4}}; + int*p=g(&y[1].a); + if(n==1)p=g(&x[1].a); + if(n==2)p=g(&x[0].b); + return p; // { dg-warning "may return address of local variable" } +} +int*s() +{ + static int i; + return &i; +} diff --git a/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455-2.c b/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455-2.c new file mode 100644 index 00000000000..60b424873d9 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455-2.c @@ -0,0 +1,13 @@ +/* PR c++/61455 */ +/* { dg-options "-fcilkplus" } */ + +int a[3] = {2, 3, 4}; + +int main () +{ + int c = 10; + int b = __sec_reduce_add(a[:]); + if (b+c != 19) + __builtin_abort(); + return 0; +} diff --git a/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455.c b/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455.c new file mode 100644 index 00000000000..35a11b66c91 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61455.c @@ -0,0 +1,9 @@ +/* PR c++/61455 */ +/* { dg-do compile } */ +/* { dg-options "-fcilkplus" } */ + +void foo () +{ + int a[2]; + int b = a[:]; /* { dg-error "cannot be scalar" } */ +} diff --git a/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61963.c b/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61963.c new file mode 100644 index 00000000000..dfa713c4df2 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/cilk-plus/AN/pr61963.c @@ -0,0 +1,9 @@ +/* PR other/61963 */ +/* { dg-do compile } */ +/* { dg-options "-fcilkplus" } */ + +void f (int * int *a) /* { dg-error "expected" } */ +{ + a[0:64] = 0; /* { dg-error "was not declared" "" { target c++ } 7 } */ + a[0:64] = 0; +} diff --git a/main/gcc/testsuite/c-c++-common/ubsan/align-1.c b/main/gcc/testsuite/c-c++-common/ubsan/align-1.c new file mode 100644 index 00000000000..2e40e839261 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/ubsan/align-1.c @@ -0,0 +1,41 @@ +/* { dg-do run } */ +/* { dg-options "-fsanitize=undefined -fno-sanitize-recover" } */ + +struct S { int a; char b; long long c; short d[10]; }; +struct T { char a; long long b; }; +struct U { char a; int b; int c; long long d; struct S e; struct T f; }; +struct V { long long a; struct S b; struct T c; struct U u; } v; + +__attribute__((noinline, noclone)) void +f1 (int *p, int *q, char *r, long long *s) +{ + *p = *q + *r + *s; +} + + +__attribute__((noinline, noclone)) int +f2 (struct S *p) +{ + return p->a; +} + +__attribute__((noinline, noclone)) long long +f3 (struct S *p, int i) +{ + return p->c + p->d[1] + p->d[i]; +} + +__attribute__((noinline, noclone)) long long +f4 (long long *p) +{ + return *p; +} + +int +main () +{ + f1 (&v.u.b, &v.u.c, &v.u.a, &v.u.d); + if (f2 (&v.u.e) + f3 (&v.u.e, 4) + f4 (&v.u.f.b) != 0) + __builtin_abort (); + return 0; +} diff --git a/main/gcc/testsuite/c-c++-common/ubsan/align-2.c b/main/gcc/testsuite/c-c++-common/ubsan/align-2.c new file mode 100644 index 00000000000..071de8c202a --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/ubsan/align-2.c @@ -0,0 +1,56 @@ +/* Limit this to known non-strict alignment targets. */ +/* { dg-do run { target { i?86-*-linux* x86_64-*-linux* } } } */ +/* { dg-options "-fsanitize=alignment" } */ + +struct S { int a; char b; long long c; short d[10]; }; +struct T { char a; long long b; }; +struct U { char a; int b; int c; long long d; struct S e; struct T f; } __attribute__((packed)); +struct V { long long a; struct S b; struct T c; struct U u; } v; + +__attribute__((noinline, noclone)) void +f1 (int *p, int *q, char *r, long long *s) +{ + *p = + *q + + *r + + *s; +} + + +__attribute__((noinline, noclone)) int +f2 (struct S *p) +{ + return p->a; +} + +__attribute__((noinline, noclone)) long long +f3 (struct S *p, int i) +{ + return p->c + + p->d[1] + + p->d[i]; +} + +__attribute__((noinline, noclone)) long long +f4 (long long *p) +{ + return *p; +} + +int +main () +{ + f1 (&v.u.b, &v.u.c, &v.u.a, &v.u.d); + if (f2 (&v.u.e) + f3 (&v.u.e, 4) + f4 (&v.u.f.b) != 0) + __builtin_abort (); + return 0; +} + +/* { dg-output "\.c:(14|15):\[0-9]*: \[^\n\r]*load of misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } */ +/* { dg-output "\.c:16:\[0-9]*: \[^\n\r]*load of misaligned address 0x\[0-9a-fA-F]* for type 'long long int', which requires \[48] byte alignment.*" } */ +/* { dg-output "\.c:(13|16):\[0-9]*: \[^\n\r]*store to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } */ +/* { dg-output "\.c:23:\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\.c:(29|30):\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\.c:30:\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\.c:31:\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\.c:37:\[0-9]*: \[^\n\r]*load of misaligned address 0x\[0-9a-fA-F]* for type 'long long int', which requires \[48] byte alignment" } */ diff --git a/main/gcc/testsuite/c-c++-common/ubsan/align-3.c b/main/gcc/testsuite/c-c++-common/ubsan/align-3.c new file mode 100644 index 00000000000..a509fa992e5 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/ubsan/align-3.c @@ -0,0 +1,66 @@ +/* { dg-do run } */ +/* { dg-options "-fsanitize=undefined -fno-sanitize-recover" } */ + +int c; + +__attribute__((noinline, noclone)) void +f1 (int *a, char *b) +{ + __builtin_memcpy (a, b, sizeof (*a)); +} + +__attribute__((noinline, noclone)) void +f2 (int *a, char *b) +{ + __builtin_memcpy (b, a, sizeof (*a)); +} + +__attribute__((noinline, noclone)) void +f3 (char *b) +{ + __builtin_memcpy (&c, b, sizeof (c)); +} + +__attribute__((noinline, noclone)) void +f4 (char *b) +{ + __builtin_memcpy (b, &c, sizeof (c)); +} + +struct T +{ + char a; + short b; + int c; + long d; + long long e; + short f; + float g; + double h; + long double i; +} __attribute__((packed)); + +__attribute__((noinline, noclone)) int +f5 (struct T *p) +{ + return p->a + p->b + p->c + p->d + p->e + p->f + p->g + p->h + p->i; +} + +int +main () +{ + struct S { int a; char b[sizeof (int) + 1]; } s; + s.a = 6; + f2 (&s.a, &s.b[1]); + f1 (&s.a, &s.b[1]); + c = s.a + 1; + f4 (&s.b[1]); + f3 (&s.b[1]); + if (c != 7 || s.a != 6) + __builtin_abort (); + struct U { long long a; long double b; char c; struct T d; } u; + __builtin_memset (&u, 0, sizeof (u)); + if (f5 (&u.d) != 0) + __builtin_abort (); + return 0; +} diff --git a/main/gcc/testsuite/c-c++-common/ubsan/align-4.c b/main/gcc/testsuite/c-c++-common/ubsan/align-4.c new file mode 100644 index 00000000000..3252595d330 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/ubsan/align-4.c @@ -0,0 +1,14 @@ +/* Limit this to known non-strict alignment targets. */ +/* { dg-do run { target { i?86-*-linux* x86_64-*-linux* } } } */ +/* { dg-options "-fsanitize=null,alignment" } */ + +#include "align-2.c" + +/* { dg-output "\.c:(14|15):\[0-9]*: \[^\n\r]*load of misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:16:\[0-9]*: \[^\n\r]*load of misaligned address 0x\[0-9a-fA-F]* for type 'long long int', which requires \[48] byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:(13|16):\[0-9]*: \[^\n\r]*store to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:23:\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:(29|30):\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:30:\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:31:\[0-9]*: \[^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct S', which requires \[48] byte alignment.*" } */ +/* { dg-output "\[^\n\r]*\.c:37:\[0-9]*: \[^\n\r]*load of misaligned address 0x\[0-9a-fA-F]* for type 'long long int', which requires \[48] byte alignment" } */ diff --git a/main/gcc/testsuite/c-c++-common/ubsan/align-5.c b/main/gcc/testsuite/c-c++-common/ubsan/align-5.c new file mode 100644 index 00000000000..b94e167bb67 --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/ubsan/align-5.c @@ -0,0 +1,15 @@ +/* { dg-do compile } */ +/* { dg-options "-fno-sanitize=null -fsanitize=alignment -O2" } */ +/* Check that when optimizing if we know the alignment is right + and we are not doing -fsanitize=null instrumentation we don't + instrument the alignment check. */ + +__attribute__((noinline, noclone)) int +foo (char *p) +{ + p = (char *) __builtin_assume_aligned (p, __alignof__(int)); + int *q = (int *) p; + return *q; +} + +/* { dg-final { scan-assembler-not "__ubsan_handle" } } */ diff --git a/main/gcc/testsuite/c-c++-common/ubsan/attrib-4.c b/main/gcc/testsuite/c-c++-common/ubsan/attrib-4.c new file mode 100644 index 00000000000..ba0f00cfb7f --- /dev/null +++ b/main/gcc/testsuite/c-c++-common/ubsan/attrib-4.c @@ -0,0 +1,15 @@ +/* { dg-do compile } */ +/* { dg-options "-fsanitize=undefined" } */ + +/* Test that we don't instrument functions marked with + no_sanitize_undefined attribute. */ + +struct S { int a[16]; }; + +__attribute__((no_sanitize_undefined)) long long +foo (int *a, long long *b, struct S *c) +{ + return a[1] + *b + c->a[a[0]]; +} + +/* { dg-final { scan-assembler-not "__ubsan_handle" } } */ diff --git a/main/gcc/testsuite/c-c++-common/uninit-G.c b/main/gcc/testsuite/c-c++-common/uninit-G.c index 08f5f532116..1a06f0665c1 100644 --- a/main/gcc/testsuite/c-c++-common/uninit-G.c +++ b/main/gcc/testsuite/c-c++-common/uninit-G.c @@ -2,8 +2,9 @@ /* { dg-do compile } */ /* { dg-options "-O -Wuninitialized" } */ -void *f() +void g(void*); +void f() { void *i = &i; - return i; + g(i); } diff --git a/main/gcc/testsuite/g++.dg/compat/struct-layout-1.exp b/main/gcc/testsuite/g++.dg/compat/struct-layout-1.exp index 0beb5953723..6a131139551 100644 --- a/main/gcc/testsuite/g++.dg/compat/struct-layout-1.exp +++ b/main/gcc/testsuite/g++.dg/compat/struct-layout-1.exp @@ -90,6 +90,9 @@ proc compat-use-tst-compiler { } { # This must be done after the compat-use-*-compiler definitions. load_lib compat.exp +# Provide the g++-dg-prune routine (gcc-dp.exp is loaded by compat.exp) +load_lib g++-dg.exp + g++_init # Save variables for the C++ compiler under test, which each test will diff --git a/main/gcc/testsuite/g++.dg/cpp0x/vt-57397-1.C b/main/gcc/testsuite/g++.dg/cpp0x/vt-57397-1.C new file mode 100644 index 00000000000..1d9a1e07619 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/cpp0x/vt-57397-1.C @@ -0,0 +1,22 @@ +// PR c++/57397 +// { dg-do compile { target c++11 } } + +template +void foo(T1, Tn...); + +template +void bar(T1, T2, Tn...); + +int main() +{ + foo(); // { dg-error "no matching" } + // { dg-message "candidate expects at least 1 argument, 0 provided" "" { target *-*-* } 12 } + foo(1); + foo(1, 2); + bar(); // { dg-error "no matching" } + // { dg-message "candidate expects at least 2 arguments, 0 provided" "" { target *-*-* } 16 } + bar(1); // { dg-error "no matching" } + // { dg-message "candidate expects at least 2 arguments, 1 provided" "" { target *-*-* } 18 } + bar(1, 2); + bar(1, 2, 3); +} diff --git a/main/gcc/testsuite/g++.dg/cpp0x/vt-57397-2.C b/main/gcc/testsuite/g++.dg/cpp0x/vt-57397-2.C new file mode 100644 index 00000000000..d217008fbfe --- /dev/null +++ b/main/gcc/testsuite/g++.dg/cpp0x/vt-57397-2.C @@ -0,0 +1,24 @@ +// PR c++/57397 +// { dg-do compile { target c++11 } } + +template +void foo(T1, Tn..., Tm...); + +template +void bar(T1, T2, Tn..., Tm...); + +int main() +{ + foo(); // { dg-error "no matching" } + // { dg-message "candidate expects at least 1 argument, 0 provided" "" { target *-*-* } 12 } + foo(1); + foo(1, 2); + foo(1, 2, 3); + bar(); // { dg-error "no matching" } + // { dg-message "candidate expects at least 2 arguments, 0 provided" "" { target *-*-* } 17 } + bar(1); // { dg-error "no matching" } + // { dg-message "candidate expects at least 2 arguments, 1 provided" "" { target *-*-* } 19 } + bar(1, 2); + bar(1, 2, 3); + bar(1, 2, 3, 4); +} diff --git a/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-neg.C b/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-neg.C new file mode 100644 index 00000000000..29c699d0fd2 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-neg.C @@ -0,0 +1,11 @@ +// { dg-do compile } +// { dg-options "" } + +template struct X> // { dg-error "expected .class. or .typename. before" } + struct D {}; + +template X> // { dg-error "expected .class. or .typename. before" } + struct E {}; + +// { dg-error "expected identifier" "expected" { target *-*-* } 4 } +// { dg-error "expected .>." "expected" { target *-*-* } 4 } diff --git a/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-ped-neg.C b/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-ped-neg.C new file mode 100644 index 00000000000..48cb8ab0892 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm-ped-neg.C @@ -0,0 +1,28 @@ +// { dg-do compile { target c++1y_down } } +// { dg-options "-pedantic" } + +template + struct A {}; + +#if __cplusplus >= 201103L +template + using B = int; +#endif + +template class X> + struct C {}; + +C ca; + +#if __cplusplus >= 201103L +C cb; +#endif + +template typename X> // { dg-warning "ISO C.. forbids typename key in template template parameter" } + struct D {}; + +D da; + +#if __cplusplus >= 201103L +D db; +#endif diff --git a/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm.C b/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm.C new file mode 100644 index 00000000000..4c3eae11203 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/cpp1z/typename-tmpl-tmpl-parm.C @@ -0,0 +1,28 @@ +// { dg-do compile } +// { dg-options "" } + +template + struct A {}; + +#if __cplusplus >= 201103L +template + using B = int; +#endif + +template class X> + struct C {}; + +C ca; + +#if __cplusplus >= 201103L +C cb; +#endif + +template typename X> + struct D {}; + +D da; + +#if __cplusplus >= 201103L +D db; +#endif diff --git a/main/gcc/testsuite/g++.dg/init/explicit2.C b/main/gcc/testsuite/g++.dg/init/explicit2.C new file mode 100644 index 00000000000..d1dbb39fc61 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/init/explicit2.C @@ -0,0 +1,8 @@ +// PR c++/60417 + +struct A { explicit A(int = 0); }; + +int main() +{ + A a[1] = { }; +} diff --git a/main/gcc/testsuite/g++.dg/ipa/devirt-34.C b/main/gcc/testsuite/g++.dg/ipa/devirt-34.C new file mode 100644 index 00000000000..5d56e1e0c8b --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ipa/devirt-34.C @@ -0,0 +1,20 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-ipa-devirt" } */ +struct A {virtual int t(){return 42;}}; +struct B:A {virtual int t(){return 1;}}; + +struct A aa; +struct B bb; +int +t(struct B *b) +{ + struct A *a=b; + a->t(); +} + +/* We should guess that the pointer of type B probably points to an instance + of B or its derivates and exclude A::t from list of likely targets. */ + +/* { dg-final { scan-ipa-dump "Targets that are not likely" "devirt" } } */ +/* { dg-final { scan-ipa-dump "1 speculatively devirtualized" "devirt" } } */ +/* { dg-final { cleanup-ipa-dump "devirt" } } */ diff --git a/main/gcc/testsuite/g++.dg/opt/devirt4.C b/main/gcc/testsuite/g++.dg/opt/devirt4.C index 5a24eecbd0a..72f56afcadc 100644 --- a/main/gcc/testsuite/g++.dg/opt/devirt4.C +++ b/main/gcc/testsuite/g++.dg/opt/devirt4.C @@ -1,8 +1,7 @@ // PR lto/53808 -// Devirtualization + inlining should produce a non-virtual -// call to ~foo. -// { dg-options "-O -fdevirtualize" } -// { dg-final { scan-assembler "_ZN3fooD2Ev" } } +// Devirtualization should not produce an external ref to ~bar. +// { dg-options "-O2" } +// { dg-final { scan-assembler-not "_ZN3barD0Ev" } } struct foo { virtual ~foo(); diff --git a/main/gcc/testsuite/g++.dg/other/default10.C b/main/gcc/testsuite/g++.dg/other/default10.C new file mode 100644 index 00000000000..1c9731e2fa7 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/other/default10.C @@ -0,0 +1,4 @@ +// PR c++/15339 + +template void g3(int, int); +template void g3(int = 0, int) { } // { dg-error "may not have default arguments|default argument missing" } diff --git a/main/gcc/testsuite/g++.dg/other/default3.C b/main/gcc/testsuite/g++.dg/other/default3.C index 42c1fe48922..025d2c1b461 100644 --- a/main/gcc/testsuite/g++.dg/other/default3.C +++ b/main/gcc/testsuite/g++.dg/other/default3.C @@ -25,7 +25,7 @@ template void g3(int, int); template void g3(int = 0, int); // { dg-error "default" } template void g4(int, int); -template void g4(int = 0, int) {} // { dg-error "default" "" { xfail *-*-* } } +template void g4(int = 0, int) {} // { dg-error "default" } template void g5(); template void g5(int = 0, int); // { dg-error "default" } diff --git a/main/gcc/testsuite/g++.dg/other/default9.C b/main/gcc/testsuite/g++.dg/other/default9.C new file mode 100644 index 00000000000..62f0a791527 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/other/default9.C @@ -0,0 +1,18 @@ +// PR c++/15339 + +template void fun(int); +template void fun(int = 0); // { dg-error "default arguments" } + +class A +{ + template void fun(int); +}; + +template void A::fun(int = 0) { } // { dg-error "default arguments" } + +class B +{ + void fun(int); +}; + +void B::fun(int = 0) { } diff --git a/main/gcc/testsuite/g++.dg/tc1/dr217-2.C b/main/gcc/testsuite/g++.dg/tc1/dr217-2.C new file mode 100644 index 00000000000..75c40f8b209 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/tc1/dr217-2.C @@ -0,0 +1,13 @@ +// { dg-do compile } +// DR217: Default arguments for non-template member functions of class +// templates + +template +struct S +{ + static void foo (int); +}; + +template +void S::foo (int = 0) // { dg-error "" "default arguments for parameters of member functions of class templates can be specified in the initial declaration only" } +{ } diff --git a/main/gcc/testsuite/g++.dg/template/dtor9.C b/main/gcc/testsuite/g++.dg/template/dtor9.C index 006a75489d6..fd71389b865 100644 --- a/main/gcc/testsuite/g++.dg/template/dtor9.C +++ b/main/gcc/testsuite/g++.dg/template/dtor9.C @@ -1,5 +1,4 @@ // PR c++/60347 -// { dg-options "-fno-use-all-virtuals" } struct A; diff --git a/main/gcc/testsuite/g++.dg/template/dtor9a.C b/main/gcc/testsuite/g++.dg/template/dtor9a.C deleted file mode 100644 index aaae8b6add0..00000000000 --- a/main/gcc/testsuite/g++.dg/template/dtor9a.C +++ /dev/null @@ -1,13 +0,0 @@ -// PR c++/60347 -// { dg-options "-fuse-all-virtuals" } - -struct A; - -template -struct B -{ - T* p; - virtual ~B() { p->~T(); } // { dg-error "incomplete" } -}; - -struct C: B { }; diff --git a/main/gcc/testsuite/g++.dg/template/friend56.C b/main/gcc/testsuite/g++.dg/template/friend56.C new file mode 100644 index 00000000000..7dd5d486f86 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/template/friend56.C @@ -0,0 +1,13 @@ +// Make sure we don't mistakenly mark f as DECL_COMDAT. +// { dg-final { scan-assembler "_Z1fv" } } + +void f(); + +template struct A +{ + friend void f(); +}; + +A a; + +void f() { } diff --git a/main/gcc/testsuite/g++.dg/tree-prof/morefunc.C b/main/gcc/testsuite/g++.dg/tree-prof/morefunc.C new file mode 100644 index 00000000000..d5cee40cd26 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/tree-prof/morefunc.C @@ -0,0 +1,55 @@ +/* { dg-options "-O2 -fno-devirtualize --param=profile-func-internal-id=0 -fdump-ipa-profile -Wno-attributes -Wno-coverage-mismatch" } */ +#include "reorder_class1.h" +#include "reorder_class2.h" + +int g; + +#ifdef _PROFILE_USE +/* Another function not existing + * in profile-gen */ + +__attribute__((noinline)) void +new_func (int i) +{ + g += i; +} +#endif + +static __attribute__((always_inline)) +void test1 (A *tc) +{ + int i; + for (i = 0; i < 1000; i++) + g += tc->foo(); + if (g<100) g++; +} + +static __attribute__((always_inline)) +void test2 (B *tc) +{ + int i; + for (i = 0; i < 1000; i++) + g += tc->foo(); +} + + +__attribute__((noinline)) void test_a(A *ap) { test1 (ap); } +__attribute__((noinline)) void test_b(B *bp) { test2 (bp); } + + +int main() +{ + A* ap = new A(); + B* bp = new B(); + + test_a(ap); + test_b(bp); + +#ifdef _PROFILE_USE + new_func(10); +#endif + +} + +/* { dg-final-use { scan-ipa-dump-times "Indirect call -> direct call" 2 "profile" } } */ + diff --git a/main/gcc/testsuite/g++.dg/tree-prof/reorder.C b/main/gcc/testsuite/g++.dg/tree-prof/reorder.C new file mode 100644 index 00000000000..223bcf94f4f --- /dev/null +++ b/main/gcc/testsuite/g++.dg/tree-prof/reorder.C @@ -0,0 +1,48 @@ +/* { dg-options "-O2 -fno-devirtualize --param=profile-func-internal-id=0 -fdump-ipa-profile -Wno-coverage-mismatch -Wno-attributes" } */ + +#ifdef _PROFILE_USE +#include "reorder_class1.h" +#include "reorder_class2.h" +#else +#include "reorder_class2.h" +#include "reorder_class1.h" +#endif + +int g; +static __attribute__((always_inline)) +void test1 (A *tc) +{ + int i; + for (i = 0; i < 1000; i++) + g += tc->foo(); + if (g<100) g++; +} + +static __attribute__((always_inline)) +void test2 (B *tc) +{ + int i; + for (i = 0; i < 1000; i++) + g += tc->foo(); +} + + +#ifdef _PROFILE_USE +__attribute__((noinline)) void test_a(A *ap) { test1 (ap); } +__attribute__((noinline)) void test_b(B *bp) { test2 (bp); } +#else +__attribute__((noinline)) void test_b(B *bp) { test2 (bp); } +__attribute__((noinline)) void test_a(A *ap) { test1 (ap); } +#endif + +int main() +{ + A* ap = new A(); + B* bp = new B(); + + test_a(ap); + test_b(bp); +} + +/* { dg-final-use { scan-ipa-dump-times "Indirect call -> direct call" 2 "profile" } } */ + diff --git a/main/gcc/testsuite/g++.dg/tree-prof/reorder_class1.h b/main/gcc/testsuite/g++.dg/tree-prof/reorder_class1.h new file mode 100644 index 00000000000..62a1e923c75 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/tree-prof/reorder_class1.h @@ -0,0 +1,11 @@ +struct A { + virtual int foo(); +}; + +int A::foo() +{ + return 1; +} + + + diff --git a/main/gcc/testsuite/g++.dg/tree-prof/reorder_class2.h b/main/gcc/testsuite/g++.dg/tree-prof/reorder_class2.h new file mode 100644 index 00000000000..ee3ed109b9e --- /dev/null +++ b/main/gcc/testsuite/g++.dg/tree-prof/reorder_class2.h @@ -0,0 +1,12 @@ + +struct B { + virtual int foo(); +}; + +int B::foo() +{ + return 2; +} + + + diff --git a/main/gcc/testsuite/g++.dg/tree-prof/tree-prof.exp b/main/gcc/testsuite/g++.dg/tree-prof/tree-prof.exp index 2c96ee38c1f..f12ddaf86dc 100644 --- a/main/gcc/testsuite/g++.dg/tree-prof/tree-prof.exp +++ b/main/gcc/testsuite/g++.dg/tree-prof/tree-prof.exp @@ -42,8 +42,8 @@ set PROFOPT_OPTIONS [list {}] # These are globals used by profopt-execute. The first is options # needed to generate profile data, the second is options to use the # profile data. -set profile_option "-fprofile-generate" -set feedback_option "-fprofile-use" +set profile_option "-fprofile-generate -D_PROFILE_GENERATE" +set feedback_option "-fprofile-use -D_PROFILE_USE" foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.C]] { # If we're only testing specific files and this isn't one of them, skip it. diff --git a/main/gcc/testsuite/g++.dg/ubsan/align-1.C b/main/gcc/testsuite/g++.dg/ubsan/align-1.C new file mode 100644 index 00000000000..65b1222a5c0 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ubsan/align-1.C @@ -0,0 +1,27 @@ +// { dg-do run } +// { dg-options "-fsanitize=alignment -Wall -Wno-unused-variable -std=c++11" } + +typedef const long int L; +int a = 1; +L b = 2; + +int +main (void) +{ + int *p = &a; + L *l = &b; + + int &r = *p; + auto &r2 = *p; + L &lr = *l; + + // Try an rvalue reference. + auto &&r3 = *p; + + // Don't evaluate the reference initializer twice. + int i = 1; + int *q = &i; + int &qr = ++*q; + if (i != 2) + __builtin_abort (); +} diff --git a/main/gcc/testsuite/g++.dg/ubsan/align-2.C b/main/gcc/testsuite/g++.dg/ubsan/align-2.C new file mode 100644 index 00000000000..3e4f5485d02 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ubsan/align-2.C @@ -0,0 +1,45 @@ +// Limit this to known non-strict alignment targets. +// { dg-do run { target { i?86-*-linux* x86_64-*-linux* } } } +// { dg-options "-fsanitize=alignment -Wall -Wno-unused-variable -std=c++11" } + +typedef const long int L; +struct S { long int l; char buf[1 + sizeof (int) + sizeof (L)]; } s; +struct T { char a; int b; long int c; } __attribute__((packed)); +struct U { long int a; struct T b; } u; + +int +main (void) +{ + int *p = (int *) &s.buf[1]; + L *l = (L *) &s.buf[1 + sizeof(int)]; + + int &r = *p; + auto &r2 = *p; + L &lr = *l; + + // Try an rvalue reference. + auto &&r3 = *p; + + // Don't evaluate the reference initializer twice. + int i = 1; + int *q = &i; + int &qr = ++*q; + if (i != 2) + __builtin_abort (); + + int *s = &u.b.b; + L *t = &u.b.c; + int &r4 = *s; + auto &r5 = *s; + L &lr2 = *t; + auto &&r6 = *s; +} + +// { dg-output "\.C:16:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } +// { dg-output "\.C:17:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } +// { dg-output "\.C:18:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'const L', which requires \[48] byte alignment.*" } +// { dg-output "\.C:21:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } +// { dg-output "\.C:32:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } +// { dg-output "\.C:33:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment.*" } +// { dg-output "\.C:34:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'const L', which requires \[48] byte alignment.*" } +// { dg-output "\.C:35:\[0-9]*:\[\^\n\r]*reference binding to misaligned address 0x\[0-9a-fA-F]* for type 'int', which requires 4 byte alignment" } diff --git a/main/gcc/testsuite/g++.dg/ubsan/align-3.C b/main/gcc/testsuite/g++.dg/ubsan/align-3.C new file mode 100644 index 00000000000..1cc40fc4c9b --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ubsan/align-3.C @@ -0,0 +1,45 @@ +// Limit this to known non-strict alignment targets. +// { dg-do run { target { i?86-*-linux* x86_64-*-linux* } } } +// { dg-options "-fsanitize=alignment -Wall -Wno-unused-variable -std=c++11" } + +#include + +struct U +{ + int a; + void foo () {} +}; +struct V +{ + V () : a (0) {}; + ~V () { a = 0; }; + int a; + void foo () {} + static void bar () {} +}; +struct S { long int l; char buf[1 + sizeof (U) + 2 * sizeof (V)]; } s; + +int +main (void) +{ + U *p = (U *) &s.buf[1]; + p->foo (); + char *q = &s.buf[1 + sizeof (U)]; + V *u = new (q) V; + u->a = 1; + u->~V (); + V *v = new (&s.buf[1 + sizeof (U) + sizeof (V)]) V; + v->foo (); + v->bar (); // We don't instrument this right now. + v->~V (); +} + +// { dg-output "\.C:26:\[0-9]*:\[\^\n\r]*member call on misaligned address 0x\[0-9a-fA-F]* for type 'struct U', which requires 4 byte alignment.*" } +// { dg-output "\.C:28:\[0-9]*:\[\^\n\r]*constructor call on misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:14:\[0-9]*:\[\^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:29:\[0-9]*:\[\^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:30:\[0-9]*:\[\^\n\r]*member call on misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:15:\[0-9]*:\[\^\n\r]*member access within misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:31:\[0-9]*:\[\^\n\r]*constructor call on misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:32:\[0-9]*:\[\^\n\r]*member call on misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment.*" } +// { dg-output "\.C:34:\[0-9]*:\[\^\n\r]*member call on misaligned address 0x\[0-9a-fA-F]* for type 'struct V', which requires 4 byte alignment" } diff --git a/main/gcc/testsuite/g++.dg/ubsan/attrib-1.C b/main/gcc/testsuite/g++.dg/ubsan/attrib-1.C new file mode 100644 index 00000000000..f701d02dad3 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ubsan/attrib-1.C @@ -0,0 +1,27 @@ +// { dg-do compile } +// { dg-options "-fsanitize=undefined -Wall -Wno-unused-variable -std=c++11" } + +typedef const long int L; + +__attribute__((no_sanitize_undefined)) void +foo (int *p, L *l) +{ + int &r = *p; + auto &r2 = *p; + L &lr = *l; + auto &&r3 = *p; +} + +struct U +{ + int a; + void foo () {} +}; + +__attribute__((no_sanitize_undefined)) void +bar (U *p) +{ + p->foo (); +} + +// { dg-final { scan-assembler-not "__ubsan_handle" } } diff --git a/main/gcc/testsuite/g++.dg/ubsan/null-1.C b/main/gcc/testsuite/g++.dg/ubsan/null-1.C new file mode 100644 index 00000000000..e1524b1f922 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ubsan/null-1.C @@ -0,0 +1,30 @@ +// { dg-do run } +// { dg-options "-fsanitize=null -Wall -Wno-unused-variable -std=c++11" } + +typedef const long int L; + +int +main (void) +{ + int *p = 0; + L *l = 0; + + int &r = *p; + auto &r2 = *p; + L &lr = *l; + + // Try an rvalue reference. + auto &&r3 = *p; + + // Don't evaluate the reference initializer twice. + int i = 1; + int *q = &i; + int &qr = ++*q; + if (i != 2) + __builtin_abort (); +} + +// { dg-output "reference binding to null pointer of type 'int'(\n|\r\n|\r)" } +// { dg-output "\[^\n\r]*reference binding to null pointer of type 'int'(\n|\r\n|\r)" } +// { dg-output "\[^\n\r]*reference binding to null pointer of type 'const L'(\n|\r\n|\r)" } +// { dg-output "\[^\n\r]*reference binding to null pointer of type 'int'(\n|\r\n|\r)" } diff --git a/main/gcc/testsuite/g++.dg/ubsan/null-2.C b/main/gcc/testsuite/g++.dg/ubsan/null-2.C new file mode 100644 index 00000000000..88f387e17c9 --- /dev/null +++ b/main/gcc/testsuite/g++.dg/ubsan/null-2.C @@ -0,0 +1,39 @@ +// Limit this to known non-strict alignment targets. +// { dg-do run { target { i?86-*-linux* x86_64-*-linux* } } } +// { dg-options "-fsanitize=null -Wall -Wno-unused-variable -std=c++11" } + +#include + +struct U +{ + int a; + void foo () {} +}; +struct V +{ + V () {}; + ~V () {}; + int a; + void foo () {} + static void bar () {} +}; +struct S { long int l; char buf[1 + sizeof (U) + 2 * sizeof (V)]; } s; + +int +main (void) +{ + U *p = 0; + p->foo (); + char *q = 0; + V *u = new (q) V; + u->~V (); + V *v = new (q) V; + v->foo (); + v->bar (); // We don't instrument this right now. + v->~V (); +} + +// { dg-output "\.C:26:\[0-9]*:\[\^\n\r]*member call on null pointer of type 'struct U'.*" } +// { dg-output "\.C:29:\[0-9]*:\[\^\n\r]*member call on null pointer of type 'struct V'.*" } +// { dg-output "\.C:31:\[0-9]*:\[\^\n\r]*member call on null pointer of type 'struct V'.*" } +// { dg-output "\.C:33:\[0-9]*:\[\^\n\r]*member call on null pointer of type 'struct V'" } diff --git a/main/gcc/testsuite/g++.dg/warn/Wsuggest-final.C b/main/gcc/testsuite/g++.dg/warn/Wsuggest-final.C new file mode 100644 index 00000000000..5371063559d --- /dev/null +++ b/main/gcc/testsuite/g++.dg/warn/Wsuggest-final.C @@ -0,0 +1,14 @@ +// { dg-do compile } +// { dg-options "-O2 -Wsuggest-final-types -Wsuggest-final-methods" } +struct A { // { dg-warning "final would enable devirtualization of 4 calls" } +virtual void a() {} // { dg-warning "final would enable devirtualization of 2 calls" } + virtual void b() {} // { dg-warning "final would enable devirtualization of 2 calls" } +}; +void +t(struct A *a) +{ + a->a(); + a->a(); + a->b(); + a->b(); +} diff --git a/main/gcc/testsuite/gcc.c-torture/execute/20050316-1.x b/main/gcc/testsuite/gcc.c-torture/execute/20050316-1.x index 121fcfecc2c..cb2d28fd9fc 100644 --- a/main/gcc/testsuite/gcc.c-torture/execute/20050316-1.x +++ b/main/gcc/testsuite/gcc.c-torture/execute/20050316-1.x @@ -4,4 +4,5 @@ if { [check_effective_target_int16] } { return 1 } +set additional_flags "-Wno-psabi" return 0; diff --git a/main/gcc/testsuite/gcc.c-torture/execute/20050316-3.x b/main/gcc/testsuite/gcc.c-torture/execute/20050316-3.x new file mode 100644 index 00000000000..cb7b119b8cb --- /dev/null +++ b/main/gcc/testsuite/gcc.c-torture/execute/20050316-3.x @@ -0,0 +1,2 @@ +set additional_flags "-Wno-psabi" +return 0 diff --git a/main/gcc/testsuite/gcc.c-torture/execute/20050604-1.x b/main/gcc/testsuite/gcc.c-torture/execute/20050604-1.x index f5b4aaae3d9..756242d2345 100644 --- a/main/gcc/testsuite/gcc.c-torture/execute/20050604-1.x +++ b/main/gcc/testsuite/gcc.c-torture/execute/20050604-1.x @@ -6,4 +6,5 @@ if { [istarget "i?86-*-*"] || [istarget "x86_64-*-*"] } { set additional_flags "-mno-mmx" } +set additional_flags "-Wno-psabi" return 0 diff --git a/main/gcc/testsuite/gcc.c-torture/execute/pr23135.x b/main/gcc/testsuite/gcc.c-torture/execute/pr23135.x new file mode 100644 index 00000000000..cb7b119b8cb --- /dev/null +++ b/main/gcc/testsuite/gcc.c-torture/execute/pr23135.x @@ -0,0 +1,2 @@ +set additional_flags "-Wno-psabi" +return 0 diff --git a/main/gcc/testsuite/gcc.dg/Wdesignated-init-2.c b/main/gcc/testsuite/gcc.dg/Wdesignated-init-2.c new file mode 100644 index 00000000000..d5edfba64c9 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/Wdesignated-init-2.c @@ -0,0 +1,15 @@ +/* PR c/59855 */ +/* { dg-do compile } */ +/* { dg-options "-std=gnu11" } */ + +struct S { + int a; + union { + int b; + int c; + }; +} __attribute__((designated_init)); + +struct S s1 = { .a = 0, .b = 0 }; +struct S s2 = { 0, 0 }; /* { dg-warning "(positional|near initialization)" } */ +struct S s3 = { .a = 5, 0 }; /* { dg-warning "(positional|near initialization)" } */ diff --git a/main/gcc/testsuite/gcc.dg/Wdesignated-init.c b/main/gcc/testsuite/gcc.dg/Wdesignated-init.c new file mode 100644 index 00000000000..b9ca572206c --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/Wdesignated-init.c @@ -0,0 +1,107 @@ +/* PR c/59855 */ +/* { dg-do compile } */ +/* { dg-options "-std=gnu99" } */ + +typedef int vvv __attribute__((designated_init)); /* { dg-error "only valid" } */ + +union U { + int a; + double b; +} __attribute__((designated_init)); /* { dg-error "only valid" } */ + +enum E { ONE, TWO } __attribute__((designated_init)); /* { dg-error "only valid" } */ + +struct Pok { + int x; + int y; +}; + +struct Des { + int x; + int y; +} __attribute__ ((designated_init)); + +struct Des d1 = { 5, 5 }; /* { dg-warning "(positional|near initialization)" } */ +struct Des d2 = { .x = 5, .y = 5 }; +struct Des d3 = { .x = 5, 5 }; /* { dg-warning "(positional|near initialization)" } */ + +struct Des fd1 (void) +{ + return (struct Des) { 5, 5 }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Des fd2 (void) +{ + return (struct Des) { .x = 5, .y = 5 }; +} + +struct Des fd3 (void) +{ + return (struct Des) { .x = 5, 5 }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Wrap { + struct Pok p; + struct Des d; +} __attribute__ ((designated_init)); + +struct Wrap w1 = { { 0, 1 }, { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +struct Wrap w2 = { .p = { 0, 1 }, { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +struct Wrap w3 = { .p = { 0, 1 }, .d = { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +struct Wrap w4 = { { 0, 1 }, .d = { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +struct Wrap w5 = { .p = { 0, 1 }, .d = { .x = 2, .y = 3} }; + +struct Wrap w6 = { { 0, 1 }, .d.x = 2, .d.y = 3 }; /* { dg-warning "(positional|near initialization)" } */ +struct Wrap w7 = { .p = { 0, 1 }, .d.x = 2, .d.y = 3 }; +struct Wrap w8 = { .p = { 0, 1 }, .d = { 2, 0 }, .d.y = 3 }; /* { dg-warning "(positional|near initialization)" } */ +struct Wrap w9 = { .p = { 0, 1 }, .d = { .x = 2 }, .d.y = 3 }; + +struct Wrap fw1 (void) +{ + return (struct Wrap) { { 0, 1 }, { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +}; + +struct Wrap fw2 (void) +{ + return (struct Wrap) { .p = { 0, 1 }, { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Wrap fw3 (void) +{ + return (struct Wrap) { .p = { 0, 1 }, .d = { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Wrap fw4 (void) +{ + return (struct Wrap) { { 0, 1 }, .d = { 2, 3} }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Wrap fw5 (void) +{ + return (struct Wrap) { .p = { 0, 1 }, .d = { .x = 2, .y = 3} }; +} + +struct Wrap fw6 (void) +{ + return (struct Wrap) { { 0, 1 }, .d.x = 2, .d.y = 3 }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Wrap fw7 (void) +{ + return (struct Wrap) { .p = { 0, 1 }, .d.x = 2, .d.y = 3 }; +} + +struct Wrap fw8 (void) +{ + return (struct Wrap) { .p = { 0, 1 }, .d = { 2, 0 }, .d.y = 3 }; /* { dg-warning "(positional|near initialization)" } */ +} + +struct Wrap fw9 (void) +{ + return (struct Wrap) { .p = { 0, 1 }, .d = { .x = 2 }, .d.y = 3 }; +} + +struct Des da[] = { + { .x = 1, .y = 2 }, + { 5, 5 } /* { dg-warning "(positional|near initialization)" } */ +}; diff --git a/main/gcc/testsuite/gcc.dg/Wstrict-overflow-25.c b/main/gcc/testsuite/gcc.dg/Wstrict-overflow-25.c index 00916446371..774474d1123 100644 --- a/main/gcc/testsuite/gcc.dg/Wstrict-overflow-25.c +++ b/main/gcc/testsuite/gcc.dg/Wstrict-overflow-25.c @@ -7,5 +7,5 @@ int foo (int x, int y) { - return x - y < 0; /* { dg-warning "assuming signed overflow does not occur" "correct warning" } */ + return x - y < 0; /* { dg-warning "assuming signed overflow does not occur" "correct warning" { xfail *-*-* } } */ } diff --git a/main/gcc/testsuite/gcc.dg/case-bogus-1.c b/main/gcc/testsuite/gcc.dg/case-bogus-1.c new file mode 100644 index 00000000000..548312edf9e --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/case-bogus-1.c @@ -0,0 +1,8 @@ +/* { dg-do compile } */ + +void +foo (int n) +{ + switch (n) + case 0: case 3: case 0.2: case 5:; /* { dg-error "21:case label does not reduce to an integer constant" } */ +} diff --git a/main/gcc/testsuite/gcc.dg/cproj-fails-with-broken-glibc.c b/main/gcc/testsuite/gcc.dg/cproj-fails-with-broken-glibc.c index fe143b9ea5b..fc37faca225 100644 --- a/main/gcc/testsuite/gcc.dg/cproj-fails-with-broken-glibc.c +++ b/main/gcc/testsuite/gcc.dg/cproj-fails-with-broken-glibc.c @@ -7,7 +7,7 @@ Origin: Kaveh R. Ghazi, April 20, 2010. */ -/* { dg-do run } */ +/* { dg-do run { xfail glibc_2_11_or_earlier } } */ /* { dg-options "-fno-builtin-cproj" } */ /* { dg-add-options c99_runtime } */ /* { dg-require-effective-target c99_runtime } */ diff --git a/main/gcc/testsuite/gcc.dg/fold-abs-5.c b/main/gcc/testsuite/gcc.dg/fold-abs-5.c new file mode 100644 index 00000000000..dba4e4bf89a --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/fold-abs-5.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-tree-original" } */ + +int test (int a, int b, int sum) +{ + sum += ((a - b) > 0 ? (a - b) : -(a - b)); + return sum; +} + +/* { dg-final { scan-tree-dump "ABS" "original" } } */ +/* { dg-final { cleanup-tree-dump "original" } } */ diff --git a/main/gcc/testsuite/gcc.dg/fold-compare-8.c b/main/gcc/testsuite/gcc.dg/fold-compare-8.c index b6e42fdef10..2fb5fe9d1d4 100644 --- a/main/gcc/testsuite/gcc.dg/fold-compare-8.c +++ b/main/gcc/testsuite/gcc.dg/fold-compare-8.c @@ -7,5 +7,5 @@ foo (int x, int y) return x - y < 0; } -/* { dg-final { scan-tree-dump "x < y" "original" } } */ +/* { dg-final { scan-tree-dump "x < y" "original" { xfail *-*-* } } } */ /* { dg-final { cleanup-tree-dump "original" } } */ diff --git a/main/gcc/testsuite/gcc.dg/fold-cstring.c b/main/gcc/testsuite/gcc.dg/fold-cstring.c new file mode 100644 index 00000000000..f92b120b3b7 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/fold-cstring.c @@ -0,0 +1,44 @@ +/* { dg-do run } */ +/* { dg-options "-O" } */ + +/* The following are testcases for native_interpret_int, + native_interpret_complex and native_interpret_vector decoding + pieces of a string constant encoded by native_encode_string. */ + +extern void abort (void); + +/* We should fold all reads from xconstant and eliminate it, removing + the reference to blah which cannot be resolved at link time. */ +extern int blah; + +static const struct { + int *y; + const char x[32] __attribute__((aligned(32))); +} xconstant = { &blah, "01234567899876543210123456789000" }; + +typedef int v4si __attribute__((vector_size(16))); + +int main() +{ + if (sizeof (int) != 4) + return 0; + if (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) + { + if (*(int *)&xconstant.x[4] != 0x34353637) + abort (); + if ((*(v4si *)&xconstant.x[16])[1] != 0x31323334) + abort (); + if (__imag (*(_Complex int *)&xconstant.x[8]) != 0x37363534) + abort (); + } + else if (__BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__) + { + if (*(int *)&xconstant.x[4] != 0x37363534) + abort (); + if ((*(v4si *)&xconstant.x[16])[1] != 0x34333231) + abort (); + if (__imag (*(_Complex int *)&xconstant.x[8]) != 0x34353637) + abort (); + } + return 0; +} diff --git a/main/gcc/testsuite/gcc.dg/fold-cvect.c b/main/gcc/testsuite/gcc.dg/fold-cvect.c new file mode 100644 index 00000000000..8687f8db2ad --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/fold-cvect.c @@ -0,0 +1,38 @@ +/* { dg-do run } */ +/* { dg-options "-O" } */ + +extern void abort (void); + +/* We should fold all reads from xconstant and eliminate it, removing + the reference to blah which cannot be resolved at link time. */ +extern int blah; + +typedef int v4si __attribute__((vector_size(16))); + +static const struct { + int *y; + const v4si x[2] __attribute__((aligned(32))); +} xconstant = { &blah, { { 0, 1, 2, 3 }, { 2, 3, 4, 5 } } }; + +int main() +{ + if (sizeof (int) != 4) + return 0; + if (*(int *)&xconstant.x[0][0] != 0) + abort (); + if (*(int *)&xconstant.x[0][1] != 1) + abort (); + if (*(int *)&xconstant.x[0][2] != 2) + abort (); + if (*(int *)&xconstant.x[0][3] != 3) + abort (); + if (*(int *)&xconstant.x[1][0] != 2) + abort (); + if (*(int *)&xconstant.x[1][1] != 3) + abort (); + if (*(int *)&xconstant.x[1][2] != 4) + abort (); + if (*(int *)&xconstant.x[1][3] != 5) + abort (); + return 0; +} diff --git a/main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-1.c b/main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-1.c new file mode 100644 index 00000000000..867b84e8359 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-1.c @@ -0,0 +1,37 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -fgraphite-identity -fgraphite-code-generator=isl" } */ + +int st = 1; +static void __attribute__((noinline)) +foo (int a[], int n) +{ + int i; + for (i = 0; i < n; i++) + { + if (i < 25) + a[i] = i; + a[n - i] = 1; + } +} + +static int __attribute__((noinline)) +array_sum (int a[]) +{ + int i, res = 0; + for(i = 0; i < 50; i += st) + res += a[i]; + return res; +} + +extern void abort (); + +int +main (void) +{ + int a[50]; + foo (a, 50); + int res = array_sum (a); + if (res != 49) + abort (); + return 0; +} diff --git a/main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-2.c b/main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-2.c new file mode 100644 index 00000000000..512e43daca6 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/graphite/isl-ast-gen-if-2.c @@ -0,0 +1,31 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -fgraphite-identity -fgraphite-code-generator=isl" } */ + +/* This test case tests reduction, where the pbbs are duplicated. */ + +static int __attribute__((noinline)) +foo () +{ + int i, res = 0; + + for (i = 0; i < 50; i++) + { + if (i >= 25) + res += i; + } + + return res; +} + +extern void abort (); + +int +main (void) +{ + int res = foo (); + + if (res != 925) + abort (); + + return 0; +} diff --git a/main/gcc/testsuite/gcc.dg/pr51879-7.c b/main/gcc/testsuite/gcc.dg/pr51879-7.c index 6c1d3209c92..8a699a1dbde 100644 --- a/main/gcc/testsuite/gcc.dg/pr51879-7.c +++ b/main/gcc/testsuite/gcc.dg/pr51879-7.c @@ -1,8 +1,6 @@ /* { dg-do compile } */ /* { dg-options "-O2 -fdump-tree-pre" } */ -int bar (int); - int z; void diff --git a/main/gcc/testsuite/gcc.dg/pr61077.c b/main/gcc/testsuite/gcc.dg/pr61077.c index c0513f71f70..e29f23cce51 100644 --- a/main/gcc/testsuite/gcc.dg/pr61077.c +++ b/main/gcc/testsuite/gcc.dg/pr61077.c @@ -5,8 +5,8 @@ _Atomic int main (_Atomic int argc, _Atomic char **argv) /* { dg-warning "qualified return type" "return" { target *-*-* } 6 } */ -/* { dg-warning "qualified parameter type.*int" "parameter" { target *-*-* } 6 } */ -/* { dg-warning "qualified parameter type.*char" "parameter" { target *-*-* } 6 } */ +/* { dg-warning "qualified parameter type\[^\n\]*int" "parameter" { target *-*-* } 6 } */ +/* { dg-warning "qualified parameter type\[^\n\]*char" "parameter" { target *-*-* } 6 } */ { return 0; } diff --git a/main/gcc/testsuite/gcc.dg/pr61756.c b/main/gcc/testsuite/gcc.dg/pr61756.c new file mode 100644 index 00000000000..c0212907558 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/pr61756.c @@ -0,0 +1,15 @@ +/* PR target/61756 */ + +/* { dg-do compile } */ +/* { dg-options "-O2" } */ +/* { dg-options "-O2 -march=armv5" { target arm*-*-* } } */ + +#include + +static volatile atomic_flag guard = ATOMIC_FLAG_INIT; + +void +try_atomic_flag_test_and_set (void) +{ + atomic_flag_test_and_set (&guard); +} diff --git a/main/gcc/testsuite/gcc.dg/pr61762.c b/main/gcc/testsuite/gcc.dg/pr61762.c new file mode 100644 index 00000000000..47dc140248c --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/pr61762.c @@ -0,0 +1,19 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fdump-tree-release_ssa" } */ + +unsigned int f() +{ + static const char string[] __attribute__((aligned(sizeof(int)))) = "Private"; + + unsigned int priv; + __builtin_memcpy(&priv, &string[0], sizeof(priv)); + return priv; +} + +/* We should have removed the static string and simplified the + memcpy to a store from an integer constant. CCP + already performs the simplification but only after release_ssa + the unused local static is removed. */ + +/* { dg-final { scan-tree-dump-not "Private" "release_ssa" } } */ +/* { dg-final { cleanup-tree-dump "release_ssa" } } */ diff --git a/main/gcc/testsuite/gcc.dg/pr61861.c b/main/gcc/testsuite/gcc.dg/pr61861.c new file mode 100644 index 00000000000..d9028686e26 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/pr61861.c @@ -0,0 +1,37 @@ +/* { dg-do compile } */ +/* { dg-prune-output "expected" } */ + +extern void foo (int); +extern void bar (int, char *); + +#define F __FILE__ /* { dg-error "11:passing argument" } */ +#define T __TIME__ /* { dg-error "11:passing argument" } */ +#define D __DATE__ /* { dg-error "11:passing argument" } */ +#define L __LINE__ /* { dg-error "11:passing argument" } */ + +#define F2 "foo" /* { dg-error "12:passing argument" } */ +#define T2 "foo" /* { dg-error "12:passing argument" } */ +#define D2 "foo" /* { dg-error "12:passing argument" } */ +#define L2 42 /* { dg-error "12:passing argument" } */ + +void +f (void) +{ + foo (__FILE__); /* { dg-error "8:passing argument" } */ + foo (__BASE_FILE__); /* { dg-error "8:passing argument" } */ + foo (__TIME__); /* { dg-error "8:passing argument" } */ + foo (__DATE__); /* { dg-error "8:passing argument" } */ + foo (__TIMESTAMP__); /* { dg-error "8:passing argument" } */ + bar (1, __LINE__); /* { dg-error "11:passing argument" } */ + bar (__COUNTER__, __COUNTER__); /* { dg-error "21:passing argument" } */ + + foo (F); /* { dg-message "8:in expansion of" } */ + foo (T); /* { dg-message "8:in expansion of" } */ + foo (D); /* { dg-message "8:in expansion of" } */ + bar (1, L); /* { dg-message "11:in expansion of" } */ + + foo (F2); /* { dg-message "8:in expansion of" } */ + foo (T2); /* { dg-message "8:in expansion of" } */ + foo (D2); /* { dg-message "8:in expansion of" } */ + bar (1, L2); /* { dg-message "11:in expansion of" } */ +} diff --git a/main/gcc/testsuite/gcc.dg/pr61868.c b/main/gcc/testsuite/gcc.dg/pr61868.c new file mode 100644 index 00000000000..a2872a9ec79 --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/pr61868.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ +/* { dg-options "-flto -frandom-seed=0x12345" } */ +extern int foo (int); +int main () +{ + foo (100); + return 0; +} +/* { dg-final { scan-assembler "\.gnu\.lto.*.12345" } } */ diff --git a/main/gcc/testsuite/gcc.dg/torture/ftrapv-1.c b/main/gcc/testsuite/gcc.dg/torture/ftrapv-1.c new file mode 100644 index 00000000000..4fdccd887ae --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/torture/ftrapv-1.c @@ -0,0 +1,37 @@ +/* { dg-do run } */ +/* { dg-additional-options "-ftrapv" } */ +/* { dg-require-effective-target trapping } */ +/* { dg-require-fork } */ + +#include +#include +#include +#include + +/* Verify SImode operations properly trap. PR middle-end/52478 */ + +/* Disallow inlining/cloning which would constant propagate and trigger + unrelated bugs. */ + +int __attribute__((noinline,noclone)) +iaddv (int a, int b) +{ + return a + b; +} + +int main(void) +{ + pid_t child = fork (); + int status = 0; + if (child == 0) + { + volatile int x = iaddv (__INT_MAX__, 1); + exit (0); + } + else if (child == -1) + return 0; + if (wait (&status) == child + && status == 0) + abort (); + return 0; +} diff --git a/main/gcc/testsuite/gcc.dg/torture/pr61964.c b/main/gcc/testsuite/gcc.dg/torture/pr61964.c new file mode 100644 index 00000000000..a03cfdc37bd --- /dev/null +++ b/main/gcc/testsuite/gcc.dg/torture/pr61964.c @@ -0,0 +1,33 @@ +/* { dg-do run } */ + +extern void abort (void); + +struct node { struct node *next, *prev; } node; +struct head { struct node *first; } heads[5]; +int k = 2; +struct head *head = &heads[2]; + +static int __attribute__((noinline)) +foo() +{ + node.prev = (void *)head; + head->first = &node; + + struct node *n = head->first; + struct head *h = &heads[k]; + + if (n->prev == (void *)h) + h->first = n->next; + else + n->prev->next = n->next; + + n->next = h->first; + return n->next == &node; +} + +int main() +{ + if (foo ()) + abort (); + return 0; +} diff --git a/main/gcc/testsuite/gcc.target/aarch64/legitimize_stack_var_before_reload_1.c b/main/gcc/testsuite/gcc.target/aarch64/legitimize_stack_var_before_reload_1.c new file mode 100644 index 00000000000..f645cb21669 --- /dev/null +++ b/main/gcc/testsuite/gcc.target/aarch64/legitimize_stack_var_before_reload_1.c @@ -0,0 +1,21 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -fdump-rtl-expand" } */ + +extern void initialize_array (unsigned char *, int); + +int +test15 (void) +{ + unsigned char a[480]; + + initialize_array (a, 480); + + if (a[0] == 0x10) + return 1; + + return 0; +} + +/* { dg-final { scan-rtl-dump "\\(mem\[^\\n\]*\\(plus\[^\\n\]*virtual-stack-vars" "expand" } } */ + +/* { dg-final { cleanup-rtl-dump "expand" } } */ diff --git a/main/gcc/testsuite/gcc.target/aarch64/scalar_intrinsics.c b/main/gcc/testsuite/gcc.target/aarch64/scalar_intrinsics.c index 624348eb449..0e288f292e4 100644 --- a/main/gcc/testsuite/gcc.target/aarch64/scalar_intrinsics.c +++ b/main/gcc/testsuite/gcc.target/aarch64/scalar_intrinsics.c @@ -293,13 +293,28 @@ test_vtstd_u64 (uint64_t a, uint64_t b) return res; } -/* { dg-final { scan-assembler-times "\\taddp\\td\[0-9\]+, v\[0-9\]+\.2d" 1 } } */ +/* { dg-final { scan-assembler-times "\\tfaddp\\td\[0-9\]+, v\[0-9\]+\.2d" 1 } } */ +float64_t +test_vpaddd_f64 (float64x2_t a) +{ + return vpaddd_f64 (a); +} + +/* { dg-final { scan-assembler-times "\\taddp\\td\[0-9\]+, v\[0-9\]+\.2d" 2 } } */ + +int64_t test_vpaddd_s64 (int64x2_t a) { return vpaddd_s64 (a); } +uint64_t +test_vpaddd_u64 (uint64x2_t a) +{ + return vpaddd_u64 (a); +} + /* { dg-final { scan-assembler-times "\\tuqadd\\td\[0-9\]+" 1 } } */ uint64_t diff --git a/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_f64.c b/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_f64.c new file mode 100644 index 00000000000..041da8eb92c --- /dev/null +++ b/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_f64.c @@ -0,0 +1,27 @@ +/* Test the vpaddd_f64 AArch64 SIMD intrinsic. */ + +/* { dg-do run } */ +/* { dg-options "-save-temps -O3" } */ + +#include "arm_neon.h" + +#define SIZE 6 + +extern void abort (void); + +float64_t in[SIZE] = { -4.0, 4.0, -2.0, 2.0, -1.0, 1.0 }; + +int +main (void) +{ + int i; + + for (i = 0; i < SIZE / 2; ++i) + if (vpaddd_f64 (vld1q_f64 (in + 2 * i)) != 0.0) + abort (); + + return 0; +} + +/* { dg-final { scan-assembler "faddp\[ \t\]+\[dD\]\[0-9\]+, v\[0-9\].2d+\n" } } */ +/* { dg-final { cleanup-saved-temps } } */ diff --git a/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_s64.c b/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_s64.c new file mode 100644 index 00000000000..44714d2b85e --- /dev/null +++ b/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_s64.c @@ -0,0 +1,27 @@ +/* Test the vpaddd_s64 AArch64 SIMD intrinsic. */ + +/* { dg-do run } */ +/* { dg-options "-save-temps -O3" } */ + +#include "arm_neon.h" + +#define SIZE 6 + +extern void abort (void); + +int64_t in[SIZE] = { -4l, 4l, -2l, 2l, -1l, 1l }; + +int +main (void) +{ + int i; + + for (i = 0; i < SIZE / 2; ++i) + if (vpaddd_s64 (vld1q_s64 (in + 2 * i)) != 0) + abort (); + + return 0; +} + +/* { dg-final { scan-assembler "addp\[ \t\]+\[dD\]\[0-9\]+, v\[0-9\].2d+\n" } } */ +/* { dg-final { cleanup-saved-temps } } */ diff --git a/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_u64.c b/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_u64.c new file mode 100644 index 00000000000..013ca00b9da --- /dev/null +++ b/main/gcc/testsuite/gcc.target/aarch64/simd/vpaddd_u64.c @@ -0,0 +1,27 @@ +/* Test the vpaddd_u64 AArch64 SIMD intrinsic. */ + +/* { dg-do run } */ +/* { dg-options "-save-temps -O3" } */ + +#include "arm_neon.h" + +#define SIZE 6 + +extern void abort (void); + +uint64_t in[SIZE] = { 4ul, 4ul, 2ul, 2ul, 1ul, 1ul }; + +int +main (void) +{ + int i; + + for (i = 0; i < SIZE / 2; ++i) + if (vpaddd_u64 (vld1q_u64 (in + 2 * i)) != 2 * in[2 * i]) + abort (); + + return 0; +} + +/* { dg-final { scan-assembler "addp\[ \t\]+\[dD\]\[0-9\]+, v\[0-9\].2d+\n" } } */ +/* { dg-final { cleanup-saved-temps } } */ diff --git a/main/gcc/testsuite/gcc.target/arm/pr61948.c b/main/gcc/testsuite/gcc.target/arm/pr61948.c new file mode 100644 index 00000000000..411e898ea77 --- /dev/null +++ b/main/gcc/testsuite/gcc.target/arm/pr61948.c @@ -0,0 +1,16 @@ +/* PR target/61948 */ +/* { dg-do compile } */ +/* { dg-require-effective-target arm_neon_ok } */ +/* { dg-require-effective-target arm_thumb2_ok } */ +/* { dg-options "-O2 -mthumb" } */ +/* { dg-add-options arm_neon } */ + +long long f (long long *c) +{ + long long t = c[0]; + asm ("nop" : : : "r0", "r3", "r4", "r5", + "r6", "r7", "r8", "r9", + "r10", "r11", "r12", "memory"); + return t >> 1; +} + diff --git a/main/gcc/testsuite/gcc.target/i386/avx512f-vbroadcastf64x4-2.c b/main/gcc/testsuite/gcc.target/i386/avx512f-vbroadcastf64x4-2.c index f646b2c9eff..909618e48da 100644 --- a/main/gcc/testsuite/gcc.target/i386/avx512f-vbroadcastf64x4-2.c +++ b/main/gcc/testsuite/gcc.target/i386/avx512f-vbroadcastf64x4-2.c @@ -29,7 +29,7 @@ TEST (void) double res_ref[SIZE]; sign = -1; - for (i = 0; i < 2; i++) + for (i = 0; i < 4; i++) { src.a[i] = 34.67 * i * sign; sign = sign * -1; diff --git a/main/gcc/testsuite/gcc.target/i386/pr44551-1.c b/main/gcc/testsuite/gcc.target/i386/pr44551-1.c new file mode 100644 index 00000000000..b65c7bb586c --- /dev/null +++ b/main/gcc/testsuite/gcc.target/i386/pr44551-1.c @@ -0,0 +1,15 @@ +/* { dg-do compile } */ +/* { dg-options "-O2 -mavx" } */ + +#include + +__m128i +foo (__m256i x, __m128i y) +{ + __m256i r = _mm256_insertf128_si256(x, y, 1); + __m128i a = _mm256_extractf128_si256(r, 1); + return a; +} + +/* { dg-final { scan-assembler-not "vinsertf" } } */ +/* { dg-final { scan-assembler-not "vextractf" } } */ diff --git a/main/gcc/testsuite/gcc.target/i386/pr61801.c b/main/gcc/testsuite/gcc.target/i386/pr61801.c new file mode 100644 index 00000000000..c15cfd8d4b7 --- /dev/null +++ b/main/gcc/testsuite/gcc.target/i386/pr61801.c @@ -0,0 +1,22 @@ +/* { dg-do compile } */ +/* { dg-options "-Os -fcompare-debug" } */ + +int a, b, c; +void fn1 () +{ + int d; + if (fn2 () && !0) + { + b = ( + { + int e; + fn3 (); + switch (0) + default: + asm volatile("" : "=a"(e) : "0"(a), "i"(0)); + e; + }); + d = b; + } + c = d; +} diff --git a/main/gcc/testsuite/gcc.target/mips/const-anchor-1.c b/main/gcc/testsuite/gcc.target/mips/const-anchor-1.c index a5f01e4ec1a..c2726cc25fb 100644 --- a/main/gcc/testsuite/gcc.target/mips/const-anchor-1.c +++ b/main/gcc/testsuite/gcc.target/mips/const-anchor-1.c @@ -2,9 +2,9 @@ (0x1234000) used to build another constant. */ /* { dg-skip-if "code quality test" { *-*-* } { "-O0" } { "" } } */ /* { dg-final { scan-assembler-not "0x12330000|305332224" } } */ -/* { dg-final { scan-assembler "\td?addiu\t\\\$5,\\\$\[0-9\]*,-1" } } */ +/* { dg-final { scan-assembler "\td?addiu\t\\\$4,\\\$\[0-9\]*,-1" } } */ NOMIPS16 void f () { - g (0x12340001, 0x1233ffff); + g (0x1233ffff, 0x12340001); } diff --git a/main/gcc/testsuite/gcc.target/mips/const-anchor-2.c b/main/gcc/testsuite/gcc.target/mips/const-anchor-2.c index 8dad5a70b27..4932648061b 100644 --- a/main/gcc/testsuite/gcc.target/mips/const-anchor-2.c +++ b/main/gcc/testsuite/gcc.target/mips/const-anchor-2.c @@ -1,9 +1,9 @@ /* Derive a constant (0x30001) from another constant. */ /* { dg-skip-if "code quality test" { *-*-* } { "-O0" } { "" } } */ /* { dg-final { scan-assembler-not "0x300000|196608" } } */ -/* { dg-final { scan-assembler "\td?addiu\t\\\$5,\\\$\[0-9\]*,32763" } } */ +/* { dg-final { scan-assembler "\td?addiu\t\\\$4,\\\$\[0-9\]*,32763" } } */ NOMIPS16 void f () { - g (0x28006, 0x30001); + g (0x30001, 0x28006); } diff --git a/main/gcc/testsuite/gcc.target/mips/const-anchor-1.c b/main/gcc/testsuite/gcc.target/mips/const-anchor-3.c similarity index 67% copy from main/gcc/testsuite/gcc.target/mips/const-anchor-1.c copy to main/gcc/testsuite/gcc.target/mips/const-anchor-3.c index a5f01e4ec1a..5988cc40967 100644 --- a/main/gcc/testsuite/gcc.target/mips/const-anchor-1.c +++ b/main/gcc/testsuite/gcc.target/mips/const-anchor-3.c @@ -1,8 +1,9 @@ /* Derive a constant (0x1233ffff) from an intermediate value (0x1234000) used to build another constant. */ /* { dg-skip-if "code quality test" { *-*-* } { "-O0" } { "" } } */ -/* { dg-final { scan-assembler-not "0x12330000|305332224" } } */ -/* { dg-final { scan-assembler "\td?addiu\t\\\$5,\\\$\[0-9\]*,-1" } } */ +/* See PR61926 for the XFAILs. */ +/* { dg-final { scan-assembler-not "0x12330000|305332224" { xfail *-*-* } } } */ +/* { dg-final { scan-assembler "\td?addiu\t\\\$5,\\\$\[0-9\]*,-1" { xfail *-*-* } } } */ NOMIPS16 void f () { diff --git a/main/gcc/testsuite/gcc.target/mips/const-anchor-2.c b/main/gcc/testsuite/gcc.target/mips/const-anchor-4.c similarity index 62% copy from main/gcc/testsuite/gcc.target/mips/const-anchor-2.c copy to main/gcc/testsuite/gcc.target/mips/const-anchor-4.c index 8dad5a70b27..a9e2631caf7 100644 --- a/main/gcc/testsuite/gcc.target/mips/const-anchor-2.c +++ b/main/gcc/testsuite/gcc.target/mips/const-anchor-4.c @@ -1,7 +1,8 @@ /* Derive a constant (0x30001) from another constant. */ /* { dg-skip-if "code quality test" { *-*-* } { "-O0" } { "" } } */ -/* { dg-final { scan-assembler-not "0x300000|196608" } } */ -/* { dg-final { scan-assembler "\td?addiu\t\\\$5,\\\$\[0-9\]*,32763" } } */ +/* See PR61926 for the XFAILs. */ +/* { dg-final { scan-assembler-not "0x300000|196608" { xfail *-*-* } } } */ +/* { dg-final { scan-assembler "\td?addiu\t\\\$5,\\\$\[0-9\]*,32763" { xfail *-*-* } } } */ NOMIPS16 void f () { diff --git a/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-1.c b/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-1.c new file mode 100644 index 00000000000..c70c14c2858 --- /dev/null +++ b/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-1.c @@ -0,0 +1,12 @@ +/* { dg-do compile { target { powerpc*-*-linux* && lp64 } } } */ +/* { dg-options "-mabi=elfv2" } */ + +struct f8 + { + float x[8]; + }; + +void test (struct f8 a, struct f8 b) /* { dg-message "note: the ABI of passing homogeneous float aggregates has changed" } */ +{ +} + diff --git a/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-2.c b/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-2.c new file mode 100644 index 00000000000..fdbeddfcbba --- /dev/null +++ b/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-2.c @@ -0,0 +1,11 @@ +/* { dg-do compile { target { powerpc*-*-linux* && lp64 } } } */ + +struct test + { + long a __attribute__((aligned (16))); + }; + +void test (struct test a) /* { dg-message "note: the ABI of passing aggregates with 16-byte alignment has changed" } */ +{ +} + diff --git a/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-3.c b/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-3.c new file mode 100644 index 00000000000..22cad0ccd5c --- /dev/null +++ b/main/gcc/testsuite/gcc.target/powerpc/ppc64-abi-warn-3.c @@ -0,0 +1,9 @@ +/* { dg-do compile { target { powerpc*-*-linux* && lp64 } } } */ +/* { dg-require-effective-target powerpc_altivec_ok } */ +/* { dg-options "-maltivec" } */ + +struct test + { + int a __attribute__((vector_size (8))); + }; /* { dg-message "note: the layout of aggregates containing vectors with 8-byte alignment has changed" } */ + diff --git a/main/gcc/testsuite/gcc.target/powerpc/pr60102.c b/main/gcc/testsuite/gcc.target/powerpc/pr60102.c new file mode 100644 index 00000000000..d32e41d6873 --- /dev/null +++ b/main/gcc/testsuite/gcc.target/powerpc/pr60102.c @@ -0,0 +1,11 @@ +/* { dg-do compile } */ +/* { dg-skip-if "not an SPE target" { ! powerpc_spe_nocache } { "*" } { "" } } */ +/* { dg-options "-mcpu=8548 -mspe -mabi=spe -g -mfloat-gprs=double" } */ + +double +pr60102 (double x, int m) +{ + double y; + y = m % 2 ? x : 1; + return y; +} diff --git a/main/gcc/testsuite/gfortran.dg/pr61921.f90 b/main/gcc/testsuite/gfortran.dg/pr61921.f90 new file mode 100644 index 00000000000..52b61762a01 --- /dev/null +++ b/main/gcc/testsuite/gfortran.dg/pr61921.f90 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-O2 -fipa-pta" } +MODULE min_heap + TYPE heap_t + END TYPE heap_t +CONTAINS + ELEMENTAL FUNCTION get_left_child(n) RESULT (child) + INTEGER, INTENT(IN) :: n + END FUNCTION get_left_child + ELEMENTAL FUNCTION get_value(heap, n) RESULT (value) + TYPE(heap_t), INTENT(IN) :: heap + INTEGER, INTENT(IN) :: n + END FUNCTION get_value +END MODULE min_heap + diff --git a/main/gcc/testsuite/gfortran.dg/sizeof_2.f90 b/main/gcc/testsuite/gfortran.dg/sizeof_2.f90 index 5f192882806..e6661a56b30 100644 --- a/main/gcc/testsuite/gfortran.dg/sizeof_2.f90 +++ b/main/gcc/testsuite/gfortran.dg/sizeof_2.f90 @@ -10,7 +10,7 @@ subroutine foo(x, y) integer(8) :: ii procedure() :: proc - ii = sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic sizeof" } + ii = sizeof (x) ! { dg-error "'x' argument of 'sizeof' intrinsic at \\(1\\) shall not be TYPE\\(\\*\\)" } ii = c_sizeof (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic c_sizeof" } ii = storage_size (x) ! { dg-error "Assumed-type argument at .1. is not permitted as actual argument to the intrinsic storage_size" } diff --git a/main/gcc/testsuite/gfortran.dg/storage_size_1.f08 b/main/gcc/testsuite/gfortran.dg/storage_size_1.f08 index ade9dfc30b0..71d3589c8ed 100644 --- a/main/gcc/testsuite/gfortran.dg/storage_size_1.f08 +++ b/main/gcc/testsuite/gfortran.dg/storage_size_1.f08 @@ -25,7 +25,7 @@ if (storage_size(a) /= 64) call abort() if (sizeof(b) /= 24) call abort() if (storage_size(b) /= 64) call abort() -if (sizeof(cp) /= 8) call abort() +if (sizeof(cp) /= 12) call abort() if (storage_size(cp) /= 96) call abort() end diff --git a/main/gcc/testsuite/gfortran.dg/storage_size_5.f90 b/main/gcc/testsuite/gfortran.dg/storage_size_5.f90 new file mode 100644 index 00000000000..ae0f12661f0 --- /dev/null +++ b/main/gcc/testsuite/gfortran.dg/storage_size_5.f90 @@ -0,0 +1,44 @@ +! { dg-do compile } +! { dg-options "-fdump-tree-original" } +! +subroutine test() + implicit none + integer :: i0, i1, i2, i3, i4 + i0 = kind(STORAGE_SIZE(5)) + i1 = kind(STORAGE_SIZE(5, kind=1)) + i2 = kind(STORAGE_SIZE(5, kind=2)) + i3 = kind(STORAGE_SIZE(5, kind=4)) + i4 = kind(STORAGE_SIZE(5, kind=8)) +end subroutine test + +subroutine test2(x) + implicit none + class(*) :: x + integer :: j0, j1, j2, j3, j4 + integer(1) :: k1 + integer(2) :: k2 + j0 = kind(STORAGE_SIZE(x)) + j1 = kind(STORAGE_SIZE(x, kind=1)) + j2 = kind(STORAGE_SIZE(x, kind=2)) + j3 = kind(STORAGE_SIZE(x, kind=4)) + j4 = kind(STORAGE_SIZE(x, kind=8)) + + k1 = STORAGE_SIZE(x, kind=1) + k2 = STORAGE_SIZE(x, kind=2) +end subroutine test2 + +! { dg-final { scan-tree-dump-times "i0 = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i1 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i2 = 2;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i3 = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "i4 = 8;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j0 = 4;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "j1 = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j2 = 2;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j3 = 4;" 1 "original" } } +! { dg-final { scan-tree-dump-times "j4 = 8;" 1 "original" } } + +! { dg-final { scan-tree-dump-times "k1 = \\(integer\\(kind=1\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "k2 = \\(integer\\(kind=2\\)\\)" 1 "original" } } +! { dg-final { cleanup-tree-dump "original" } } diff --git a/main/gcc/testsuite/gnat.dg/case_null.adb b/main/gcc/testsuite/gnat.dg/case_null.adb index eba89dc5f13..4b1b30ef7ce 100644 --- a/main/gcc/testsuite/gnat.dg/case_null.adb +++ b/main/gcc/testsuite/gnat.dg/case_null.adb @@ -5,7 +5,7 @@ package body Case_Null is procedure P1 (X : T) is begin case X is - when S1 => + when S1 => -- { dg-error "not.*static" } null; when e => null; diff --git a/main/gcc/testsuite/gnat.dg/discr6.adb b/main/gcc/testsuite/gnat.dg/discr6.adb deleted file mode 100644 index 52a94b1d6ad..00000000000 --- a/main/gcc/testsuite/gnat.dg/discr6.adb +++ /dev/null @@ -1,33 +0,0 @@ --- { dg-do compile } --- { dg-options "-gnatdm -gnatws" } - -with Discr6_Pkg; - -procedure Discr6 is - - type T_Bit is range 0..1; - type T_Entier_16 is range -2**15 .. 2**15-1; - - package My_Q is new Discr6_Pkg(T_Entier_16); - - type T_Valeur is (BIT, Entier_16); - - type R(D : T_Valeur) is record - case D is - when BIT => V_BIT : T_Bit; - when Entier_16 => V_E16 : T_Entier_16; - end case; - end record; - for R use record - V_BIT at 0 range 0..7; - V_E16 at 0 range 0..15; - D at 8 range 0..7; - end record; - for R'size use 128; - - A : R(Entier_16); - I : Integer; - -begin - I := My_Q.X(A.V_E16); -end; diff --git a/main/gcc/testsuite/gnat.dg/discr6_pkg.ads b/main/gcc/testsuite/gnat.dg/discr6_pkg.ads deleted file mode 100644 index 81404d4613f..00000000000 --- a/main/gcc/testsuite/gnat.dg/discr6_pkg.ads +++ /dev/null @@ -1,16 +0,0 @@ -generic - - type T(<>) is private; - -package Discr6_Pkg is - - function X (A : T) return Integer; - - pragma Interface(C, X); - pragma IMPORT_FUNCTION ( - INTERNAL => X, - EXTERNAL => X, - PARAMETER_TYPES => (T), - MECHANISM => (Descriptor(S))); - -end Discr6_Pkg; diff --git a/main/gcc/testsuite/gnat.dg/specs/debug1.ads b/main/gcc/testsuite/gnat.dg/specs/debug1.ads index 2fdc6e13e91..92e9184e473 100644 --- a/main/gcc/testsuite/gnat.dg/specs/debug1.ads +++ b/main/gcc/testsuite/gnat.dg/specs/debug1.ads @@ -11,4 +11,4 @@ package Debug1 is end Debug1; --- { dg-final { scan-assembler-times "DW_AT_artificial" 8 } } +-- { dg-final { scan-assembler-times "DW_AT_artificial" 17 } } diff --git a/main/gcc/testsuite/gnat.dg/specs/formal_type.ads b/main/gcc/testsuite/gnat.dg/specs/formal_type.ads index 4f12b82d3f5..1a6f8aadeb2 100644 --- a/main/gcc/testsuite/gnat.dg/specs/formal_type.ads +++ b/main/gcc/testsuite/gnat.dg/specs/formal_type.ads @@ -9,7 +9,6 @@ package formal_type is package G is end; package BI is new Ada.Strings.Bounded.Generic_Bounded_Length (30); type NB is new BI.Bounded_String; - Thing : NB; - Size : Integer := THing.Max_Length; + Thing : NB; package GI is new G (BI, NB); end; diff --git a/main/gcc/testsuite/lib/target-supports.exp b/main/gcc/testsuite/lib/target-supports.exp index 2d2441c7c48..1a271fa4097 100644 --- a/main/gcc/testsuite/lib/target-supports.exp +++ b/main/gcc/testsuite/lib/target-supports.exp @@ -5062,6 +5062,44 @@ proc check_effective_target_newlib {} { }] } +# Return true if this is a glibc target. + +proc check_effective_target_glibc {} { + return [check_no_compiler_messages glibc object { + #include + #if !(defined (__GLIBC__) && defined (__GLIBC_MINOR__)) + #error FOO + #endif + }] +} + +# Return true if this is a glibc 2.12 or later target. + +proc check_effective_target_glibc_2_12_or_later {} { + return [check_no_compiler_messages glibc_2_12_or_later object { + #include + #if !(defined (__GLIBC__) && defined (__GLIBC_MINOR__) \ + && __GLIBC_PREREQ(2,12)) + #error FOO + #endif + }] +} + +# Return true if this is a glibc 2.11 or earlier target. + +proc check_effective_target_glibc_2_11_or_earlier {} { + + if { ![check_effective_target_glibc] } { + return 1 + } + + if { [check_effective_target_glibc_2_12_or_later] } { + return 0 + } + + return 1 +} + # Return true if this is NOT a Bionic target. proc check_effective_target_non_bionic {} { @@ -5731,7 +5769,16 @@ proc check_effective_target_c++1y_only { } { return [check-flags { { } { } { -std=c++1y -std=gnu++1y -std=c++14 -std=gnu++14 } }] } proc check_effective_target_c++1y { } { - return [check_effective_target_c++1y_only] + if [check_effective_target_c++1y_only] { + return 1 + } + return [check_effective_target_c++1z] +} +proc check_effective_target_c++1y_down { } { + if ![check_effective_target_c++] { + return 0 + } + return ![check_effective_target_c++1z] } proc check_effective_target_c++98_only { } { @@ -5741,6 +5788,16 @@ proc check_effective_target_c++98_only { } { return ![check_effective_target_c++11] } +proc check_effective_target_c++1z_only { } { + if ![check_effective_target_c++] { + return 0 + } + return [check-flags { { } { } { -std=c++1z -std=gnu++1z } }] +} +proc check_effective_target_c++1z { } { + return [check_effective_target_c++1z_only] +} + # Return 1 if expensive testcases should be run. proc check_effective_target_run_expensive_tests { } { diff --git a/main/gcc/toplev.c b/main/gcc/toplev.c index 4e07442d456..71850cb163d 100644 --- a/main/gcc/toplev.c +++ b/main/gcc/toplev.c @@ -295,16 +295,7 @@ init_local_tick (void) static void init_random_seed (void) { - if (flag_random_seed) - { - char *endp; - - /* When the driver passed in a hex number don't crc it again */ - random_seed = strtoul (flag_random_seed, &endp, 0); - if (!(endp > flag_random_seed && *endp == 0)) - random_seed = crc32_string (0, flag_random_seed); - } - else if (!random_seed) + if (!random_seed) random_seed = local_tick ^ getpid (); /* Old racey fallback method */ } @@ -327,6 +318,15 @@ set_random_seed (const char *val) { const char *old = flag_random_seed; flag_random_seed = val; + if (flag_random_seed) + { + char *endp; + + /* When the driver passed in a hex number don't crc it again */ + random_seed = strtoul (flag_random_seed, &endp, 0); + if (!(endp > flag_random_seed && *endp == 0)) + random_seed = crc32_string (0, flag_random_seed); + } return old; } @@ -1571,9 +1571,18 @@ process_options (void) warn_stack_protect = 0; /* Address Sanitizer needs porting to each target architecture. */ + if ((flag_sanitize & SANITIZE_ADDRESS) - && (targetm.asan_shadow_offset == NULL - || !FRAME_GROWS_DOWNWARD)) + && !FRAME_GROWS_DOWNWARD) + { + warning (0, + "-fsanitize=address and -fsanitize=kernel-address " + "are not supported for this target"); + flag_sanitize &= ~SANITIZE_ADDRESS; + } + + if ((flag_sanitize & SANITIZE_USER_ADDRESS) + && targetm.asan_shadow_offset == NULL) { warning (0, "-fsanitize=address not supported for this target"); flag_sanitize &= ~SANITIZE_ADDRESS; @@ -1623,6 +1632,10 @@ backend_init_target (void) on a mode change. */ init_expmed (); init_lower_subreg (); + init_set_costs (); + + init_expr_target (); + ira_init (); /* We may need to recompute regno_save_code[] and regno_restore_code[] after a mode change as well. */ @@ -1701,7 +1714,8 @@ lang_dependent_init_target (void) front end is initialized. It also depends on the HAVE_xxx macros generated from the target machine description. */ init_optabs (); - this_target_rtl->lang_dependent_initialized = false; + + gcc_assert (!this_target_rtl->target_specific_initialized); } /* Perform initializations that are lang-dependent or target-dependent. @@ -1720,26 +1734,10 @@ initialize_rtl (void) /* Target specific RTL backend initialization. */ if (!this_target_rtl->target_specific_initialized) - backend_init_target (); - this_target_rtl->target_specific_initialized = true; - - if (this_target_rtl->lang_dependent_initialized) - return; - this_target_rtl->lang_dependent_initialized = true; - - /* The following initialization functions need to generate rtl, so - provide a dummy function context for them. */ - init_dummy_function_start (); - - /* Do the target-specific parts of expr initialization. */ - init_expr_target (); - - /* Although the actions of these functions are language-independent, - they use optabs, so we cannot call them from backend_init. */ - init_set_costs (); - ira_init (); - - expand_dummy_function_end (); + { + backend_init_target (); + this_target_rtl->target_specific_initialized = true; + } } /* Language-dependent initialization. Returns nonzero on success. */ diff --git a/main/gcc/tree-cfg.c b/main/gcc/tree-cfg.c index 4baa665e609..499bfcf646a 100644 --- a/main/gcc/tree-cfg.c +++ b/main/gcc/tree-cfg.c @@ -22,6 +22,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "hash-table.h" +#include "hash-map.h" #include "tm.h" #include "tree.h" #include "trans-mem.h" @@ -93,7 +94,7 @@ static const int initial_cfg_capacity = 20; more persistent. The key is getting notification of changes to the CFG (particularly edge removal, creation and redirection). */ -static struct pointer_map_t *edge_to_cases; +static hash_map *edge_to_cases; /* If we record edge_to_cases, this bitmap will hold indexes of basic blocks that end in a GIMPLE_SWITCH which we touched @@ -1049,19 +1050,17 @@ make_cond_expr_edges (basic_block bb) SWITCH_EXPRs and structure sharing rules, then free the hash table element. */ -static bool -edge_to_cases_cleanup (const void *key ATTRIBUTE_UNUSED, void **value, - void *data ATTRIBUTE_UNUSED) +bool +edge_to_cases_cleanup (edge const &, tree const &value, void *) { tree t, next; - for (t = (tree) *value; t; t = next) + for (t = value; t; t = next) { next = CASE_CHAIN (t); CASE_CHAIN (t) = NULL; } - *value = NULL; return true; } @@ -1071,7 +1070,7 @@ void start_recording_case_labels (void) { gcc_assert (edge_to_cases == NULL); - edge_to_cases = pointer_map_create (); + edge_to_cases = new hash_map; touched_switch_bbs = BITMAP_ALLOC (NULL); } @@ -1090,8 +1089,8 @@ end_recording_case_labels (void) { bitmap_iterator bi; unsigned i; - pointer_map_traverse (edge_to_cases, edge_to_cases_cleanup, NULL); - pointer_map_destroy (edge_to_cases); + edge_to_cases->traverse (NULL); + delete edge_to_cases; edge_to_cases = NULL; EXECUTE_IF_SET_IN_BITMAP (touched_switch_bbs, 0, i, bi) { @@ -1114,7 +1113,7 @@ end_recording_case_labels (void) static tree get_cases_for_edge (edge e, gimple t) { - void **slot; + tree *slot; size_t i, n; /* If we are not recording cases, then we do not have CASE_LABEL_EXPR @@ -1122,9 +1121,9 @@ get_cases_for_edge (edge e, gimple t) if (!recording_case_labels_p ()) return NULL; - slot = pointer_map_contains (edge_to_cases, e); + slot = edge_to_cases->get (e); if (slot) - return (tree) *slot; + return *slot; /* If we did not find E in the hash table, then this must be the first time we have been queried for information about E & T. Add all the @@ -1140,12 +1139,12 @@ get_cases_for_edge (edge e, gimple t) /* Add it to the chain of CASE_LABEL_EXPRs referencing E, or create a new chain. */ - slot = pointer_map_insert (edge_to_cases, this_edge); - CASE_CHAIN (elt) = (tree) *slot; - *slot = elt; + tree &s = edge_to_cases->get_or_insert (this_edge); + CASE_CHAIN (elt) = s; + s = elt; } - return (tree) *pointer_map_contains (edge_to_cases, e); + return *edge_to_cases->get (e); } /* Create the edges for a GIMPLE_SWITCH starting at block BB. */ @@ -2578,12 +2577,11 @@ last_and_only_stmt (basic_block bb) static void reinstall_phi_args (edge new_edge, edge old_edge) { - edge_var_map_vector *v; edge_var_map *vm; int i; gimple_stmt_iterator phis; - v = redirect_edge_var_map_vector (old_edge); + vec *v = redirect_edge_var_map_vector (old_edge); if (!v) return; @@ -4697,7 +4695,7 @@ tree_node_can_be_shared (tree t) static tree verify_node_sharing_1 (tree *tp, int *walk_subtrees, void *data) { - struct pointer_set_t *visited = (struct pointer_set_t *) data; + hash_set *visited = (hash_set *) data; if (tree_node_can_be_shared (*tp)) { @@ -4705,7 +4703,7 @@ verify_node_sharing_1 (tree *tp, int *walk_subtrees, void *data) return NULL; } - if (pointer_set_insert (visited, *tp)) + if (visited->add (*tp)) return *tp; return NULL; @@ -4725,9 +4723,9 @@ static int verify_eh_throw_stmt_node (void **slot, void *data) { struct throw_stmt_node *node = (struct throw_stmt_node *)*slot; - struct pointer_set_t *visited = (struct pointer_set_t *) data; + hash_set *visited = (hash_set *) data; - if (!pointer_set_contains (visited, node->stmt)) + if (!visited->contains (node->stmt)) { error ("dead STMT in EH table"); debug_gimple_stmt (node->stmt); @@ -4739,11 +4737,11 @@ verify_eh_throw_stmt_node (void **slot, void *data) /* Verify if the location LOCs block is in BLOCKS. */ static bool -verify_location (pointer_set_t *blocks, location_t loc) +verify_location (hash_set *blocks, location_t loc) { tree block = LOCATION_BLOCK (loc); if (block != NULL_TREE - && !pointer_set_contains (blocks, block)) + && !blocks->contains (block)) { error ("location references block not in block tree"); return true; @@ -4776,7 +4774,7 @@ verify_expr_no_block (tree *tp, int *walk_subtrees, void *) static tree verify_expr_location_1 (tree *tp, int *walk_subtrees, void *data) { - struct pointer_set_t *blocks = (struct pointer_set_t *) data; + hash_set *blocks = (hash_set *) data; if (TREE_CODE (*tp) == VAR_DECL && DECL_HAS_DEBUG_EXPR_P (*tp)) @@ -4822,12 +4820,12 @@ verify_expr_location (tree *tp, int *walk_subtrees, void *data) /* Insert all subblocks of BLOCK into BLOCKS and recurse. */ static void -collect_subblocks (pointer_set_t *blocks, tree block) +collect_subblocks (hash_set *blocks, tree block) { tree t; for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t)) { - pointer_set_insert (blocks, t); + blocks->add (t); collect_subblocks (blocks, t); } } @@ -4839,18 +4837,17 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) { basic_block bb; bool err = false; - struct pointer_set_t *visited, *visited_stmts, *blocks; timevar_push (TV_TREE_STMT_VERIFY); - visited = pointer_set_create (); - visited_stmts = pointer_set_create (); + hash_set visited; + hash_set visited_stmts; /* Collect all BLOCKs referenced by the BLOCK tree of FN. */ - blocks = pointer_set_create (); + hash_set blocks; if (DECL_INITIAL (fn->decl)) { - pointer_set_insert (blocks, DECL_INITIAL (fn->decl)); - collect_subblocks (blocks, DECL_INITIAL (fn->decl)); + blocks.add (DECL_INITIAL (fn->decl)); + collect_subblocks (&blocks, DECL_INITIAL (fn->decl)); } FOR_EACH_BB_FN (bb, fn) @@ -4863,7 +4860,7 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) bool err2 = false; unsigned i; - pointer_set_insert (visited_stmts, phi); + visited_stmts.add (phi); if (gimple_bb (phi) != bb) { @@ -4884,7 +4881,7 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) { tree arg = gimple_phi_arg_def (phi, i); tree addr = walk_tree (&arg, verify_node_sharing_1, - visited, NULL); + &visited, NULL); if (addr) { error ("incorrect sharing of tree nodes"); @@ -4898,13 +4895,13 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) error ("virtual PHI with argument locations"); err2 = true; } - addr = walk_tree (&arg, verify_expr_location_1, blocks, NULL); + addr = walk_tree (&arg, verify_expr_location_1, &blocks, NULL); if (addr) { debug_generic_expr (addr); err2 = true; } - err2 |= verify_location (blocks, loc); + err2 |= verify_location (&blocks, loc); } if (err2) @@ -4920,7 +4917,7 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) tree addr; int lp_nr; - pointer_set_insert (visited_stmts, stmt); + visited_stmts.add (stmt); if (gimple_bb (stmt) != bb) { @@ -4929,10 +4926,10 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) } err2 |= verify_gimple_stmt (stmt); - err2 |= verify_location (blocks, gimple_location (stmt)); + err2 |= verify_location (&blocks, gimple_location (stmt)); memset (&wi, 0, sizeof (wi)); - wi.info = (void *) visited; + wi.info = (void *) &visited; addr = walk_gimple_op (stmt, verify_node_sharing, &wi); if (addr) { @@ -4942,7 +4939,7 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) } memset (&wi, 0, sizeof (wi)); - wi.info = (void *) blocks; + wi.info = (void *) &blocks; addr = walk_gimple_op (stmt, verify_expr_location, &wi); if (addr) { @@ -4998,14 +4995,11 @@ verify_gimple_in_cfg (struct function *fn, bool verify_nothrow) if (get_eh_throw_stmt_table (cfun)) htab_traverse (get_eh_throw_stmt_table (cfun), verify_eh_throw_stmt_node, - visited_stmts); + &visited_stmts); if (err || eh_error_found) internal_error ("verify_gimple failed"); - pointer_set_destroy (visited); - pointer_set_destroy (visited_stmts); - pointer_set_destroy (blocks); verify_histograms (); timevar_pop (TV_TREE_STMT_VERIFY); } @@ -6284,22 +6278,20 @@ gather_blocks_in_sese_region (basic_block entry, basic_block exit, The duplicates are recorded in VARS_MAP. */ static void -replace_by_duplicate_decl (tree *tp, struct pointer_map_t *vars_map, +replace_by_duplicate_decl (tree *tp, hash_map *vars_map, tree to_context) { tree t = *tp, new_t; struct function *f = DECL_STRUCT_FUNCTION (to_context); - void **loc; if (DECL_CONTEXT (t) == to_context) return; - loc = pointer_map_contains (vars_map, t); + bool existed; + tree &loc = vars_map->get_or_insert (t, &existed); - if (!loc) + if (!existed) { - loc = pointer_map_insert (vars_map, t); - if (SSA_VAR_P (t)) { new_t = copy_var_decl (t, DECL_NAME (t), TREE_TYPE (t)); @@ -6312,10 +6304,10 @@ replace_by_duplicate_decl (tree *tp, struct pointer_map_t *vars_map, } DECL_CONTEXT (new_t) = to_context; - *loc = new_t; + loc = new_t; } else - new_t = (tree) *loc; + new_t = loc; *tp = new_t; } @@ -6325,15 +6317,14 @@ replace_by_duplicate_decl (tree *tp, struct pointer_map_t *vars_map, VARS_MAP maps old ssa names and var_decls to the new ones. */ static tree -replace_ssa_name (tree name, struct pointer_map_t *vars_map, +replace_ssa_name (tree name, hash_map *vars_map, tree to_context) { - void **loc; tree new_name; gcc_assert (!virtual_operand_p (name)); - loc = pointer_map_contains (vars_map, name); + tree *loc = vars_map->get (name); if (!loc) { @@ -6351,11 +6342,10 @@ replace_ssa_name (tree name, struct pointer_map_t *vars_map, new_name = copy_ssa_name_fn (DECL_STRUCT_FUNCTION (to_context), name, SSA_NAME_DEF_STMT (name)); - loc = pointer_map_insert (vars_map, name); - *loc = new_name; + vars_map->put (name, new_name); } else - new_name = (tree) *loc; + new_name = *loc; return new_name; } @@ -6366,9 +6356,9 @@ struct move_stmt_d tree new_block; tree from_context; tree to_context; - struct pointer_map_t *vars_map; + hash_map *vars_map; htab_t new_label_map; - struct pointer_map_t *eh_map; + hash_map *eh_map; bool remap_decls_p; }; @@ -6445,11 +6435,9 @@ static int move_stmt_eh_region_nr (int old_nr, struct move_stmt_d *p) { eh_region old_r, new_r; - void **slot; old_r = get_eh_region_from_number (old_nr); - slot = pointer_map_contains (p->eh_map, old_r); - new_r = (eh_region) *slot; + new_r = static_cast (*p->eh_map->get (old_r)); return new_r->index; } @@ -6783,7 +6771,7 @@ new_label_mapper (tree decl, void *data) subblocks. */ static void -replace_block_vars_by_duplicates (tree block, struct pointer_map_t *vars_map, +replace_block_vars_by_duplicates (tree block, hash_map *vars_map, tree to_context) { tree *tp, t; @@ -6861,7 +6849,7 @@ move_sese_region_to_fn (struct function *dest_cfun, basic_block entry_bb, edge e; edge_iterator ei; htab_t new_label_map; - struct pointer_map_t *vars_map, *eh_map; + hash_map *eh_map; struct loop *loop = entry_bb->loop_father; struct loop *loop0 = get_loop (saved_cfun, 0); struct move_stmt_d d; @@ -7005,14 +6993,14 @@ move_sese_region_to_fn (struct function *dest_cfun, basic_block entry_bb, /* Move blocks from BBS into DEST_CFUN. */ gcc_assert (bbs.length () >= 2); after = dest_cfun->cfg->x_entry_block_ptr; - vars_map = pointer_map_create (); + hash_map vars_map; memset (&d, 0, sizeof (d)); d.orig_block = orig_block; d.new_block = DECL_INITIAL (dest_cfun->decl); d.from_context = cfun->decl; d.to_context = dest_cfun->decl; - d.vars_map = vars_map; + d.vars_map = &vars_map; d.new_label_map = new_label_map; d.eh_map = eh_map; d.remap_decls_p = true; @@ -7067,13 +7055,12 @@ move_sese_region_to_fn (struct function *dest_cfun, basic_block entry_bb, } replace_block_vars_by_duplicates (DECL_INITIAL (dest_cfun->decl), - vars_map, dest_cfun->decl); + &vars_map, dest_cfun->decl); if (new_label_map) htab_delete (new_label_map); if (eh_map) - pointer_map_destroy (eh_map); - pointer_map_destroy (vars_map); + delete eh_map; /* Rewire the entry and exit blocks. The successor to the entry block turns into the successor of DEST_FN's ENTRY_BLOCK_PTR in diff --git a/main/gcc/tree-cfgcleanup.c b/main/gcc/tree-cfgcleanup.c index bc4d83ed6b6..2b6927e0437 100644 --- a/main/gcc/tree-cfgcleanup.c +++ b/main/gcc/tree-cfgcleanup.c @@ -865,16 +865,14 @@ remove_forwarder_block_with_phi (basic_block bb) if (TREE_CODE (def) == SSA_NAME) { - edge_var_map_vector *head; - edge_var_map *vm; - size_t i; - /* If DEF is one of the results of PHI nodes removed during redirection, replace it with the PHI argument that used to be on E. */ - head = redirect_edge_var_map_vector (e); - FOR_EACH_VEC_SAFE_ELT (head, i, vm) + vec *head = redirect_edge_var_map_vector (e); + size_t length = head ? head->length () : 0; + for (size_t i = 0; i < length; i++) { + edge_var_map *vm = &(*head)[i]; tree old_arg = redirect_edge_var_map_result (vm); tree new_arg = redirect_edge_var_map_def (vm); diff --git a/main/gcc/tree-core.h b/main/gcc/tree-core.h index 50b98451096..3a80f8e4f56 100644 --- a/main/gcc/tree-core.h +++ b/main/gcc/tree-core.h @@ -21,6 +21,7 @@ along with GCC; see the file COPYING3. If not see #define GCC_TREE_CORE_H #include "hashtab.h" +#include "hash-set.h" #include "machmode.h" #include "input.h" #include "statistics.h" @@ -45,7 +46,6 @@ struct fixed_value; struct ptr_info_def; struct range_info_def; struct die_struct; -struct pointer_set_t; /*--------------------------------------------------------------------------- @@ -695,7 +695,7 @@ typedef tree (*walk_tree_fn) (tree *, int *, void *); /* The type of a callback function that represents a custom walk_tree. */ typedef tree (*walk_tree_lh) (tree *, int *, tree (*) (tree *, int *, void *), - void *, struct pointer_set_t*); + void *, hash_set *); /*--------------------------------------------------------------------------- diff --git a/main/gcc/tree-eh.c b/main/gcc/tree-eh.c index df9a6fcaf7c..db2818490a9 100644 --- a/main/gcc/tree-eh.c +++ b/main/gcc/tree-eh.c @@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "function.h" #include "except.h" +#include "hash-set.h" #include "pointer-set.h" #include "basic-block.h" #include "tree-ssa-alias.h" @@ -405,7 +406,7 @@ struct leh_tf_state size_t goto_queue_active; /* Pointer map to help in searching goto_queue when it is large. */ - struct pointer_map_t *goto_queue_map; + hash_map *goto_queue_map; /* The set of unique labels seen as entries in the goto queue. */ vec dest_array; @@ -440,7 +441,6 @@ static gimple_seq find_goto_replacement (struct leh_tf_state *tf, treemple stmt) { unsigned int i; - void **slot; if (tf->goto_queue_active < LARGE_GOTO_QUEUE) { @@ -455,19 +455,18 @@ find_goto_replacement (struct leh_tf_state *tf, treemple stmt) if (!tf->goto_queue_map) { - tf->goto_queue_map = pointer_map_create (); + tf->goto_queue_map = new hash_map; for (i = 0; i < tf->goto_queue_active; i++) { - slot = pointer_map_insert (tf->goto_queue_map, - tf->goto_queue[i].stmt.g); - gcc_assert (*slot == NULL); - *slot = &tf->goto_queue[i]; + bool existed = tf->goto_queue_map->put (tf->goto_queue[i].stmt.g, + &tf->goto_queue[i]); + gcc_assert (!existed); } } - slot = pointer_map_contains (tf->goto_queue_map, stmt.g); + goto_queue_node **slot = tf->goto_queue_map->get (stmt.g); if (slot != NULL) - return (((struct goto_queue_node *) *slot)->repl_stmt); + return ((*slot)->repl_stmt); return NULL; } @@ -1371,7 +1370,7 @@ lower_try_finally_switch (struct leh_state *state, struct leh_tf_state *tf) tree tmp; gimple switch_stmt; gimple_seq finally; - struct pointer_map_t *cont_map = NULL; + hash_map *cont_map = NULL; /* The location of the TRY_FINALLY stmt. */ location_t tf_loc = gimple_location (tf->try_finally_expr); /* The location of the finally block. */ @@ -1510,32 +1509,27 @@ lower_try_finally_switch (struct leh_state *state, struct leh_tf_state *tf) if (case_label_vec.length () <= case_index || !case_label_vec[case_index]) { tree case_lab; - void **slot; tmp = build_int_cst (integer_type_node, switch_id); case_lab = build_case_label (tmp, NULL, create_artificial_label (tf_loc)); /* We store the cont_stmt in the pointer map, so that we can recover it in the loop below. */ if (!cont_map) - cont_map = pointer_map_create (); - slot = pointer_map_insert (cont_map, case_lab); - *slot = q->cont_stmt; + cont_map = new hash_map; + cont_map->put (case_lab, q->cont_stmt); case_label_vec.quick_push (case_lab); } } for (j = last_case_index; j < last_case_index + nlabels; j++) { gimple cont_stmt; - void **slot; last_case = case_label_vec[j]; gcc_assert (last_case); gcc_assert (cont_map); - slot = pointer_map_contains (cont_map, last_case); - gcc_assert (slot); - cont_stmt = *(gimple *) slot; + cont_stmt = *cont_map->get (last_case); x = gimple_build_label (CASE_LABEL (last_case)); gimple_seq_add_stmt (&switch_body, x); @@ -1543,7 +1537,7 @@ lower_try_finally_switch (struct leh_state *state, struct leh_tf_state *tf) maybe_record_in_goto_queue (state, cont_stmt); } if (cont_map) - pointer_map_destroy (cont_map); + delete cont_map; replace_goto_queue (tf); @@ -1733,7 +1727,7 @@ lower_try_finally (struct leh_state *state, gimple tp) this_tf.dest_array.release (); free (this_tf.goto_queue); if (this_tf.goto_queue_map) - pointer_map_destroy (this_tf.goto_queue_map); + delete this_tf.goto_queue_map; /* If there was an old (aka outer) eh_seq, append the current eh_seq. If there was no old eh_seq, then the append is trivially already done. */ @@ -2920,10 +2914,10 @@ maybe_clean_or_replace_eh_stmt (gimple old_stmt, gimple new_stmt) bool maybe_duplicate_eh_stmt_fn (struct function *new_fun, gimple new_stmt, struct function *old_fun, gimple old_stmt, - struct pointer_map_t *map, int default_lp_nr) + hash_map *map, + int default_lp_nr) { int old_lp_nr, new_lp_nr; - void **slot; if (!stmt_could_throw_p (new_stmt)) return false; @@ -2940,8 +2934,7 @@ maybe_duplicate_eh_stmt_fn (struct function *new_fun, gimple new_stmt, eh_landing_pad old_lp, new_lp; old_lp = (*old_fun->eh->lp_array)[old_lp_nr]; - slot = pointer_map_contains (map, old_lp); - new_lp = (eh_landing_pad) *slot; + new_lp = static_cast (*map->get (old_lp)); new_lp_nr = new_lp->index; } else @@ -2949,8 +2942,7 @@ maybe_duplicate_eh_stmt_fn (struct function *new_fun, gimple new_stmt, eh_region old_r, new_r; old_r = (*old_fun->eh->region_array)[-old_lp_nr]; - slot = pointer_map_contains (map, old_r); - new_r = (eh_region) *slot; + new_r = static_cast (*map->get (old_r)); new_lp_nr = -new_r->index; } @@ -3153,7 +3145,7 @@ make_pass_refactor_eh (gcc::context *ctxt) /* At the end of gimple optimization, we can lower RESX. */ static bool -lower_resx (basic_block bb, gimple stmt, struct pointer_map_t *mnt_map) +lower_resx (basic_block bb, gimple stmt, hash_map *mnt_map) { int lp_nr; eh_region src_r, dst_r; @@ -3198,14 +3190,13 @@ lower_resx (basic_block bb, gimple stmt, struct pointer_map_t *mnt_map) if (lp_nr < 0) { basic_block new_bb; - void **slot; tree lab; /* We are resuming into a MUST_NOT_CALL region. Expand a call to the failure decl into a new block, if needed. */ gcc_assert (dst_r->type == ERT_MUST_NOT_THROW); - slot = pointer_map_contains (mnt_map, dst_r); + tree *slot = mnt_map->get (dst_r); if (slot == NULL) { gimple_stmt_iterator gsi2; @@ -3220,12 +3211,11 @@ lower_resx (basic_block bb, gimple stmt, struct pointer_map_t *mnt_map) gimple_set_location (x, dst_r->u.must_not_throw.failure_loc); gsi_insert_after (&gsi2, x, GSI_CONTINUE_LINKING); - slot = pointer_map_insert (mnt_map, dst_r); - *slot = lab; + mnt_map->put (dst_r, lab); } else { - lab = (tree) *slot; + lab = *slot; new_bb = label_to_block (lab); } @@ -3333,24 +3323,21 @@ unsigned pass_lower_resx::execute (function *fun) { basic_block bb; - struct pointer_map_t *mnt_map; bool dominance_invalidated = false; bool any_rewritten = false; - mnt_map = pointer_map_create (); + hash_map mnt_map; FOR_EACH_BB_FN (bb, fun) { gimple last = last_stmt (bb); if (last && is_gimple_resx (last)) { - dominance_invalidated |= lower_resx (bb, last, mnt_map); + dominance_invalidated |= lower_resx (bb, last, &mnt_map); any_rewritten = true; } } - pointer_map_destroy (mnt_map); - if (dominance_invalidated) { free_dominance_info (CDI_DOMINATORS); @@ -3578,7 +3565,7 @@ lower_eh_dispatch (basic_block src, gimple stmt) eh_catch c; edge_iterator ei; edge e; - struct pointer_set_t *seen_values = pointer_set_create (); + hash_set seen_values; /* Collect the labels for a switch. Zero the post_landing_pad field becase we'll no longer have anything keeping these labels @@ -3605,12 +3592,12 @@ lower_eh_dispatch (basic_block src, gimple stmt) attached to the handler anymore, we remove the corresponding edge and then we delete unreachable blocks at the end of this pass. */ - if (! pointer_set_contains (seen_values, TREE_VALUE (flt_node))) + if (! seen_values.contains (TREE_VALUE (flt_node))) { tree t = build_case_label (TREE_VALUE (flt_node), NULL, lab); labels.safe_push (t); - pointer_set_insert (seen_values, TREE_VALUE (flt_node)); + seen_values.add (TREE_VALUE (flt_node)); have_label = true; } @@ -3662,7 +3649,6 @@ lower_eh_dispatch (basic_block src, gimple stmt) x = gimple_build_switch (filter, default_label, labels); gsi_insert_before (&gsi, x, GSI_SAME_STMT); } - pointer_set_destroy (seen_values); } break; diff --git a/main/gcc/tree-eh.h b/main/gcc/tree-eh.h index cd9b40d03c2..51c2adcc86e 100644 --- a/main/gcc/tree-eh.h +++ b/main/gcc/tree-eh.h @@ -20,6 +20,10 @@ along with GCC; see the file COPYING3. If not see #ifndef GCC_TREE_EH_H #define GCC_TREE_EH_H +#include "hash-map.h" + +typedef struct eh_region_d *eh_region; + extern void using_eh_for_cleanups (void); extern void add_stmt_to_eh_lp (gimple, int); extern bool remove_stmt_from_eh_lp_fn (struct function *, gimple); @@ -43,7 +47,7 @@ extern bool maybe_clean_eh_stmt (gimple); extern bool maybe_clean_or_replace_eh_stmt (gimple, gimple); extern bool maybe_duplicate_eh_stmt_fn (struct function *, gimple, struct function *, gimple, - struct pointer_map_t *, int); + hash_map *, int); extern bool maybe_duplicate_eh_stmt (gimple, gimple); extern void maybe_remove_unreachable_handlers (void); extern bool verify_eh_edges (gimple); diff --git a/main/gcc/tree-emutls.c b/main/gcc/tree-emutls.c index 89197c774aa..00b27b5eb09 100644 --- a/main/gcc/tree-emutls.c +++ b/main/gcc/tree-emutls.c @@ -42,7 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "target.h" #include "targhooks.h" #include "tree-iterator.h" - +#include "hash-map.h" /* Whenever a target does not support thread-local storage (TLS) natively, we can emulate it with some run-time support in libgcc. This will in @@ -67,15 +67,17 @@ along with GCC; see the file COPYING3. If not see to the symbol table early in the GIMPLE optimization path, before we write things out to LTO intermediate files. */ -/* These two vectors, once fully populated, are kept in lock-step so that - the index of a TLS variable equals the index of its control variable in - the other vector. */ -static varpool_node_set tls_vars; -static vec control_vars; +/* Value for TLS varpool node where a pointer to control variable and + access variable are stored. */ +struct tls_var_data +{ + varpool_node *control_var; + tree access; +}; -/* For the current basic block, an SSA_NAME that has computed the address - of the TLS variable at the corresponding index. */ -static vec access_vars; +/* TLS map accesses mapping between a TLS varpool node and a pair + made by control variable and access variable. */ +static hash_map *tls_map = NULL; /* The type of the control structure, shared with the emutls.c runtime. */ static tree emutls_object_type; @@ -350,33 +352,6 @@ new_emutls_decl (tree decl, tree alias_of) return to; } -/* Look up the index of the TLS variable DECL. This index can then be - used in both the control_vars and access_vars arrays. */ - -static unsigned int -emutls_index (tree decl) -{ - varpool_node_set_iterator i; - - i = varpool_node_set_find (tls_vars, varpool_node::get (decl)); - gcc_assert (i.index != ~0u); - - return i.index; -} - -/* Look up the control variable for the TLS variable DECL. */ - -static tree -emutls_decl (tree decl) -{ - varpool_node *var; - unsigned int i; - - i = emutls_index (decl); - var = control_vars[i]; - return var->decl; -} - /* Generate a call statement to initialize CONTROL_DECL for TLS_DECL. This only needs to happen for TLS COMMON variables; non-COMMON variables can be initialized statically. Insert the generated @@ -423,19 +398,17 @@ struct lower_emutls_data static tree gen_emutls_addr (tree decl, struct lower_emutls_data *d) { - unsigned int index; - tree addr; - /* Compute the address of the TLS variable with help from runtime. */ - index = emutls_index (decl); - addr = access_vars[index]; + tls_var_data *data = tls_map->get (varpool_node::get (decl)); + tree addr = data->access; + if (addr == NULL) { varpool_node *cvar; tree cdecl; gimple x; - cvar = control_vars[index]; + cvar = data->control_var; cdecl = cvar->decl; TREE_ADDRESSABLE (cdecl) = 1; @@ -455,7 +428,7 @@ gen_emutls_addr (tree decl, struct lower_emutls_data *d) d->cfun_node->add_reference (cvar, IPA_REF_ADDR, x); /* Record this ssa_name for possible use later in the basic block. */ - access_vars[index] = addr; + data->access = addr; } return addr; @@ -608,13 +581,22 @@ lower_emutls_phi_arg (gimple phi, unsigned int i, struct lower_emutls_data *d) } } -/* Clear the ACCESS_VARS array, in order to begin a new block. */ +/* Reset access variable for a given TLS variable data DATA. */ + +bool +reset_access (varpool_node * const &, tls_var_data *data, void *) +{ + data->access = NULL; + + return true; +} + +/* Clear the access variables, in order to begin a new block. */ static inline void clear_access_vars (void) { - memset (access_vars.address (), 0, - access_vars.length () * sizeof (tree)); + tls_map->traverse (NULL); } /* Lower the entire function NODE. */ @@ -705,14 +687,13 @@ static bool create_emultls_var (varpool_node *var, void *data) { tree cdecl; - varpool_node *cvar; + tls_var_data value; cdecl = new_emutls_decl (var->decl, var->alias && var->analyzed ? var->get_alias_target ()->decl : NULL); - cvar = varpool_node::get (cdecl); - control_vars.quick_push (cvar); + varpool_node *cvar = varpool_node::get (cdecl); if (!var->alias) { @@ -730,6 +711,10 @@ create_emultls_var (varpool_node *var, void *data) which is special-cased inside the DWARF2 output routines. */ SET_DECL_VALUE_EXPR (var->decl, cdecl); DECL_HAS_VALUE_EXPR_P (var->decl) = 1; + + value.control_var = cvar; + tls_map->put (var, value); + return false; } @@ -739,12 +724,11 @@ static unsigned int ipa_lower_emutls (void) { varpool_node *var; - struct cgraph_node *func; + cgraph_node *func; bool any_aliases = false; tree ctor_body = NULL; - unsigned int i, n_tls; - tls_vars = varpool_node_set_new (); + auto_vec tls_vars; /* Examine all global variables for TLS variables. */ FOR_EACH_VARIABLE (var) @@ -752,30 +736,25 @@ ipa_lower_emutls (void) { gcc_checking_assert (TREE_STATIC (var->decl) || DECL_EXTERNAL (var->decl)); - varpool_node_set_add (tls_vars, var); + tls_vars.safe_push (var); if (var->alias && var->definition) - varpool_node_set_add (tls_vars, var->ultimate_alias_target ()); + tls_vars.safe_push (var->ultimate_alias_target ()); } /* If we found no TLS variables, then there is no further work to do. */ - if (!tls_vars->nodes.exists ()) + if (tls_vars.is_empty ()) { - tls_vars = NULL; if (dump_file) fprintf (dump_file, "No TLS variables found.\n"); return 0; } - /* Allocate the on-the-side arrays that share indicies with the TLS vars. */ - n_tls = tls_vars->nodes.length (); - control_vars.create (n_tls); - access_vars.create (n_tls); - access_vars.safe_grow_cleared (n_tls); + tls_map = new hash_map (); /* Create the control variables for each TLS variable. */ - FOR_EACH_VEC_ELT (tls_vars->nodes, i, var) + for (unsigned i = 0; i < tls_vars.length (); i++) { - var = tls_vars->nodes[i]; + var = tls_vars[i]; if (var->alias && !var->analyzed) any_aliases = true; @@ -787,10 +766,12 @@ ipa_lower_emutls (void) if (any_aliases) { alias_pair *p; + unsigned int i; FOR_EACH_VEC_SAFE_ELT (alias_pairs, i, p) if (DECL_THREAD_LOCAL_P (p->decl)) { - p->decl = emutls_decl (p->decl); + p->decl = tls_map->get + (varpool_node::get (p->decl))->control_var->decl; p->target = get_emutls_object_name (p->target); } } @@ -804,9 +785,7 @@ ipa_lower_emutls (void) if (ctor_body) cgraph_build_static_cdtor ('I', ctor_body, DEFAULT_INIT_PRIORITY); - control_vars.release (); - access_vars.release (); - free_varpool_node_set (tls_vars); + delete tls_map; return 0; } diff --git a/main/gcc/tree-inline.c b/main/gcc/tree-inline.c index a0131186551..989125e6887 100644 --- a/main/gcc/tree-inline.c +++ b/main/gcc/tree-inline.c @@ -137,7 +137,7 @@ static tree declare_return_variable (copy_body_data *, tree, tree, basic_block); static void remap_block (tree *, copy_body_data *); static void copy_bind_expr (tree *, int *, copy_body_data *); static void declare_inline_vars (tree, tree); -static void remap_save_expr (tree *, void *, int *); +static void remap_save_expr (tree *, hash_map *, int *); static void prepend_lexical_block (tree current_block, tree new_block); static tree copy_decl_to_var (tree, copy_body_data *); static tree copy_result_decl_to_var (tree, copy_body_data *); @@ -151,12 +151,12 @@ static bool delete_unreachable_blocks_update_callgraph (copy_body_data *id); void insert_decl_map (copy_body_data *id, tree key, tree value) { - *pointer_map_insert (id->decl_map, key) = value; + id->decl_map->put (key, value); /* Always insert an identity map as well. If we see this same new node again, we won't want to duplicate it a second time. */ if (key != value) - *pointer_map_insert (id->decl_map, value) = value; + id->decl_map->put (value, value); } /* Insert a tree->tree mapping for ID. This is only used for @@ -178,9 +178,9 @@ insert_debug_decl_map (copy_body_data *id, tree key, tree value) gcc_assert (TREE_CODE (value) == VAR_DECL); if (!id->debug_map) - id->debug_map = pointer_map_create (); + id->debug_map = new hash_map; - *pointer_map_insert (id->debug_map, key) = value; + id->debug_map->put (key, value); } /* If nonzero, we're remapping the contents of inlined debug @@ -199,7 +199,7 @@ remap_ssa_name (tree name, copy_body_data *id) gcc_assert (TREE_CODE (name) == SSA_NAME); - n = (tree *) pointer_map_contains (id->decl_map, name); + n = id->decl_map->get (name); if (n) return unshare_expr (*n); @@ -215,7 +215,7 @@ remap_ssa_name (tree name, copy_body_data *id) gimple_stmt_iterator gsi; tree val = SSA_NAME_VAR (name); - n = (tree *) pointer_map_contains (id->decl_map, val); + n = id->decl_map->get (val); if (n != NULL) val = *n; if (TREE_CODE (val) != PARM_DECL) @@ -344,7 +344,7 @@ remap_decl (tree decl, copy_body_data *id) /* See if we have remapped this declaration. */ - n = (tree *) pointer_map_contains (id->decl_map, decl); + n = id->decl_map->get (decl); if (!n && processing_debug_stmt) { @@ -564,7 +564,7 @@ remap_type (tree type, copy_body_data *id) return type; /* See if we have remapped this type. */ - node = (tree *) pointer_map_contains (id->decl_map, type); + node = id->decl_map->get (type); if (node) return *node; @@ -889,7 +889,7 @@ remap_gimple_op_r (tree *tp, int *walk_subtrees, void *data) { /* If the enclosing record type is variably_modified_type_p, the field has already been remapped. Otherwise, it need not be. */ - tree *n = (tree *) pointer_map_contains (id->decl_map, *tp); + tree *n = id->decl_map->get (*tp); if (n) *tp = *n; *walk_subtrees = 0; @@ -983,8 +983,7 @@ remap_gimple_op_r (tree *tp, int *walk_subtrees, void *data) if (old_block) { tree *n; - n = (tree *) pointer_map_contains (id->decl_map, - TREE_BLOCK (*tp)); + n = id->decl_map->get (TREE_BLOCK (*tp)); if (n) new_block = *n; } @@ -1110,7 +1109,7 @@ copy_tree_body_r (tree *tp, int *walk_subtrees, void *data) tree decl = TREE_OPERAND (*tp, 0), value; tree *n; - n = (tree *) pointer_map_contains (id->decl_map, decl); + n = id->decl_map->get (decl); if (n) { value = *n; @@ -1127,7 +1126,7 @@ copy_tree_body_r (tree *tp, int *walk_subtrees, void *data) /* Get rid of *& from inline substitutions that can happen when a pointer argument is an ADDR_EXPR. */ tree decl = TREE_OPERAND (*tp, 0); - tree *n = (tree *) pointer_map_contains (id->decl_map, decl); + tree *n = id->decl_map->get (decl); if (n) { /* If we happen to get an ADDR_EXPR in n->value, strip @@ -1208,8 +1207,7 @@ copy_tree_body_r (tree *tp, int *walk_subtrees, void *data) if (TREE_BLOCK (*tp)) { tree *n; - n = (tree *) pointer_map_contains (id->decl_map, - TREE_BLOCK (*tp)); + n = id->decl_map->get (TREE_BLOCK (*tp)); if (n) new_block = *n; } @@ -1263,11 +1261,9 @@ static int remap_eh_region_nr (int old_nr, copy_body_data *id) { eh_region old_r, new_r; - void **slot; old_r = get_eh_region_from_number_fn (id->src_cfun, old_nr); - slot = pointer_map_contains (id->eh_map, old_r); - new_r = (eh_region) *slot; + new_r = static_cast (*id->eh_map->get (old_r)); return new_r->index; } @@ -1485,7 +1481,7 @@ remap_gimple_stmt (gimple stmt, copy_body_data *id) tree decl = gimple_assign_lhs (stmt), value; tree *n; - n = (tree *) pointer_map_contains (id->decl_map, decl); + n = id->decl_map->get (decl); if (n) { value = *n; @@ -1599,7 +1595,7 @@ remap_gimple_stmt (gimple stmt, copy_body_data *id) if (gimple_block (copy)) { tree *n; - n = (tree *) pointer_map_contains (id->decl_map, gimple_block (copy)); + n = id->decl_map->get (gimple_block (copy)); gcc_assert (n); gimple_set_block (copy, *n); } @@ -1790,7 +1786,7 @@ copy_bb (copy_body_data *id, basic_block bb, int frequency_scale, expensive, copy_body can be told to watch for nontrivial changes. */ if (id->statements_to_fold) - pointer_set_insert (id->statements_to_fold, stmt); + id->statements_to_fold->add (stmt); /* We're duplicating a CALL_EXPR. Find any corresponding callgraph edges and update or duplicate them. */ @@ -2193,8 +2189,7 @@ copy_phis_for_bb (basic_block bb, copy_body_data *id) if (LOCATION_BLOCK (locus)) { tree *n; - n = (tree *) pointer_map_contains (id->decl_map, - LOCATION_BLOCK (locus)); + n = id->decl_map->get (LOCATION_BLOCK (locus)); gcc_assert (n); if (*n) locus = COMBINE_LOCATION_DATA (line_table, locus, *n); @@ -2641,7 +2636,7 @@ copy_cfg_body (copy_body_data * id, gcov_type count, int frequency_scale, if (id->eh_map) { - pointer_map_destroy (id->eh_map); + delete id->eh_map; id->eh_map = NULL; } @@ -2662,7 +2657,7 @@ copy_debug_stmt (gimple stmt, copy_body_data *id) if (gimple_block (stmt)) { - n = (tree *) pointer_map_contains (id->decl_map, gimple_block (stmt)); + n = id->decl_map->get (gimple_block (stmt)); gimple_set_block (stmt, n ? *n : id->block); } @@ -2678,14 +2673,14 @@ copy_debug_stmt (gimple stmt, copy_body_data *id) t = gimple_debug_bind_get_var (stmt); if (TREE_CODE (t) == PARM_DECL && id->debug_map - && (n = (tree *) pointer_map_contains (id->debug_map, t))) + && (n = id->debug_map->get (t))) { gcc_assert (TREE_CODE (*n) == VAR_DECL); t = *n; } else if (TREE_CODE (t) == VAR_DECL && !is_global_var (t) - && !pointer_map_contains (id->decl_map, t)) + && !id->decl_map->get (t)) /* T is a non-localized variable. */; else walk_tree (&t, remap_gimple_op_r, &wi, NULL); @@ -3091,7 +3086,7 @@ initialize_inlined_parameters (copy_body_data *id, gimple stmt, parameter following the array. */ for (p = parms, i = 0; p; p = DECL_CHAIN (p), i++) { - tree *varp = (tree *) pointer_map_contains (id->decl_map, p); + tree *varp = id->decl_map->get (p); if (varp && TREE_CODE (*varp) == VAR_DECL) { @@ -3104,7 +3099,7 @@ initialize_inlined_parameters (copy_body_data *id, gimple stmt, by the parameter setup. */ if (def) { - tree *defp = (tree *) pointer_map_contains (id->decl_map, def); + tree *defp = id->decl_map->get (def); if (defp && TREE_CODE (*defp) == SSA_NAME && SSA_NAME_VAR (*defp) == var) @@ -3522,7 +3517,6 @@ inline_forbidden_p (tree fndecl) { struct function *fun = DECL_STRUCT_FUNCTION (fndecl); struct walk_stmt_info wi; - struct pointer_set_t *visited_nodes; basic_block bb; bool forbidden_p = false; @@ -3533,10 +3527,10 @@ inline_forbidden_p (tree fndecl) /* Next, walk the statements of the function looking for constraucts we can't handle, or are non-optimal for inlining. */ - visited_nodes = pointer_set_create (); + hash_set visited_nodes; memset (&wi, 0, sizeof (wi)); wi.info = (void *) fndecl; - wi.pset = visited_nodes; + wi.pset = &visited_nodes; FOR_EACH_BB_FN (bb, fun) { @@ -3548,7 +3542,6 @@ inline_forbidden_p (tree fndecl) break; } - pointer_set_destroy (visited_nodes); return forbidden_p; } @@ -3648,7 +3641,7 @@ tree_inlinable_function_p (tree fn) cost based on whether optimizing for size or speed according to SPEED_P. */ int -estimate_move_cost (tree type, bool speed_p) +estimate_move_cost (tree type, bool ARG_UNUSED (speed_p)) { HOST_WIDE_INT size; @@ -4167,7 +4160,8 @@ expand_call_inline (basic_block bb, gimple stmt, copy_body_data *id) { tree use_retvar; tree fn; - struct pointer_map_t *st, *dst; + hash_map *dst; + hash_map *st = NULL; tree return_slot; tree modify_dest; location_t saved_location; @@ -4323,7 +4317,7 @@ expand_call_inline (basic_block bb, gimple stmt, copy_body_data *id) /* Local declarations will be replaced by their equivalents in this map. */ st = id->decl_map; - id->decl_map = pointer_map_create (); + id->decl_map = new hash_map; dst = id->debug_map; id->debug_map = NULL; @@ -4447,10 +4441,10 @@ expand_call_inline (basic_block bb, gimple stmt, copy_body_data *id) /* Clean up. */ if (id->debug_map) { - pointer_map_destroy (id->debug_map); + delete id->debug_map; id->debug_map = dst; } - pointer_map_destroy (id->decl_map); + delete id->decl_map; id->decl_map = st; /* Unlink the calls virtual operands before replacing it. */ @@ -4561,7 +4555,7 @@ gimple_expand_calls_inline (basic_block bb, copy_body_data *id) in the STATEMENTS pointer set. */ static void -fold_marked_statements (int first, struct pointer_set_t *statements) +fold_marked_statements (int first, hash_set *statements) { for (; first < n_basic_blocks_for_fn (cfun); first++) if (BASIC_BLOCK_FOR_FN (cfun, first)) @@ -4571,7 +4565,7 @@ fold_marked_statements (int first, struct pointer_set_t *statements) for (gsi = gsi_start_bb (BASIC_BLOCK_FOR_FN (cfun, first)); !gsi_end_p (gsi); gsi_next (&gsi)) - if (pointer_set_contains (statements, gsi_stmt (gsi))) + if (statements->contains (gsi_stmt (gsi))) { gimple old_stmt = gsi_stmt (gsi); tree old_decl = is_gimple_call (old_stmt) ? gimple_call_fndecl (old_stmt) : 0; @@ -4672,7 +4666,7 @@ optimize_inline_calls (tree fn) id.transform_return_to_modify = true; id.transform_parameter = true; id.transform_lang_insert_block = NULL; - id.statements_to_fold = pointer_set_create (); + id.statements_to_fold = new hash_set; push_gimplify_context (); @@ -4708,7 +4702,7 @@ optimize_inline_calls (tree fn) /* Fold queued statements. */ fold_marked_statements (last, id.statements_to_fold); - pointer_set_destroy (id.statements_to_fold); + delete id.statements_to_fold; gcc_assert (!id.debug_stmts.exists ()); @@ -4816,14 +4810,13 @@ copy_tree_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) the function into which the copy will be placed. */ static void -remap_save_expr (tree *tp, void *st_, int *walk_subtrees) +remap_save_expr (tree *tp, hash_map *st, int *walk_subtrees) { - struct pointer_map_t *st = (struct pointer_map_t *) st_; tree *n; tree t; /* See if we already encountered this SAVE_EXPR. */ - n = (tree *) pointer_map_contains (st, *tp); + n = st->get (*tp); /* If we didn't already remap this SAVE_EXPR, do so now. */ if (!n) @@ -4831,9 +4824,9 @@ remap_save_expr (tree *tp, void *st_, int *walk_subtrees) t = copy_node (*tp); /* Remember this SAVE_EXPR. */ - *pointer_map_insert (st, *tp) = t; + st->put (*tp, t); /* Make sure we don't remap an already-remapped SAVE_EXPR. */ - *pointer_map_insert (st, t) = t; + st->put (t, t); } else { @@ -4880,7 +4873,7 @@ replace_locals_op (tree *tp, int *walk_subtrees, void *data) { struct walk_stmt_info *wi = (struct walk_stmt_info*) data; copy_body_data *id = (copy_body_data *) wi->info; - struct pointer_map_t *st = id->decl_map; + hash_map *st = id->decl_map; tree *n; tree expr = *tp; @@ -4890,7 +4883,7 @@ replace_locals_op (tree *tp, int *walk_subtrees, void *data) || TREE_CODE (expr) == LABEL_DECL) { /* Lookup the declaration. */ - n = (tree *) pointer_map_contains (st, expr); + n = st->get (expr); /* If it's there, remap it. */ if (n) @@ -4962,7 +4955,6 @@ copy_gimple_seq_and_replace_locals (gimple_seq seq) { copy_body_data id; struct walk_stmt_info wi; - struct pointer_set_t *visited; gimple_seq copy; /* There's nothing to do for NULL_TREE. */ @@ -4973,7 +4965,7 @@ copy_gimple_seq_and_replace_locals (gimple_seq seq) memset (&id, 0, sizeof (id)); id.src_fn = current_function_decl; id.dst_fn = current_function_decl; - id.decl_map = pointer_map_create (); + id.decl_map = new hash_map; id.debug_map = NULL; id.copy_decl = copy_decl_no_change; @@ -4985,11 +4977,10 @@ copy_gimple_seq_and_replace_locals (gimple_seq seq) /* Walk the tree once to find local labels. */ memset (&wi, 0, sizeof (wi)); - visited = pointer_set_create (); + hash_set visited; wi.info = &id; - wi.pset = visited; + wi.pset = &visited; walk_gimple_seq (seq, mark_local_labels_stmt, NULL, &wi); - pointer_set_destroy (visited); copy = gimple_seq_copy (seq); @@ -4999,9 +4990,9 @@ copy_gimple_seq_and_replace_locals (gimple_seq seq) walk_gimple_seq (copy, replace_locals_stmt, replace_locals_op, &wi); /* Clean up. */ - pointer_map_destroy (id.decl_map); + delete id.decl_map; if (id.debug_map) - pointer_map_destroy (id.debug_map); + delete id.debug_map; return copy; } @@ -5191,7 +5182,7 @@ copy_arguments_for_versioning (tree orig_parm, copy_body_data * id, *parg = new_tree; parg = &DECL_CHAIN (new_tree); } - else if (!pointer_map_contains (id->decl_map, arg)) + else if (!id->decl_map->get (arg)) { /* Make an equivalent VAR_DECL. If the argument was used as temporary variable later in function, the uses will be @@ -5412,9 +5403,9 @@ tree_function_versioning (tree old_decl, tree new_decl, memset (&id, 0, sizeof (id)); /* Generate a new name for the new version. */ - id.statements_to_fold = pointer_set_create (); + id.statements_to_fold = new hash_set; - id.decl_map = pointer_map_create (); + id.decl_map = new hash_map; id.debug_map = NULL; id.src_fn = old_decl; id.dst_fn = new_decl; @@ -5576,14 +5567,14 @@ tree_function_versioning (tree old_decl, tree new_decl, } /* Clean up. */ - pointer_map_destroy (id.decl_map); + delete id.decl_map; if (id.debug_map) - pointer_map_destroy (id.debug_map); + delete id.debug_map; free_dominance_info (CDI_DOMINATORS); free_dominance_info (CDI_POST_DOMINATORS); fold_marked_statements (0, id.statements_to_fold); - pointer_set_destroy (id.statements_to_fold); + delete id.statements_to_fold; fold_cond_expr_cond (); delete_unreachable_blocks_update_callgraph (&id); if (id.dst_node->definition) @@ -5633,22 +5624,22 @@ maybe_inline_call_in_expr (tree exp) /* We can only try to inline "const" functions. */ if (fn && TREE_READONLY (fn) && DECL_SAVED_TREE (fn)) { - struct pointer_map_t *decl_map = pointer_map_create (); call_expr_arg_iterator iter; copy_body_data id; tree param, arg, t; + hash_map decl_map; /* Remap the parameters. */ for (param = DECL_ARGUMENTS (fn), arg = first_call_expr_arg (exp, &iter); param; param = DECL_CHAIN (param), arg = next_call_expr_arg (&iter)) - *pointer_map_insert (decl_map, param) = arg; + decl_map.put (param, arg); memset (&id, 0, sizeof (id)); id.src_fn = fn; id.dst_fn = current_function_decl; id.src_cfun = DECL_STRUCT_FUNCTION (fn); - id.decl_map = decl_map; + id.decl_map = &decl_map; id.copy_decl = copy_decl_no_change; id.transform_call_graph_edges = CB_CGE_DUPLICATE; @@ -5666,7 +5657,6 @@ maybe_inline_call_in_expr (tree exp) id.eh_lp_nr = 0; t = copy_tree_body (&id); - pointer_map_destroy (decl_map); /* We can only return something suitable for use in a GENERIC expression tree. */ @@ -5688,15 +5678,15 @@ build_duplicate_type (tree type) id.src_fn = current_function_decl; id.dst_fn = current_function_decl; id.src_cfun = cfun; - id.decl_map = pointer_map_create (); + id.decl_map = new hash_map; id.debug_map = NULL; id.copy_decl = copy_decl_no_change; type = remap_type_1 (type, &id); - pointer_map_destroy (id.decl_map); + delete id.decl_map; if (id.debug_map) - pointer_map_destroy (id.debug_map); + delete id.debug_map; TYPE_CANONICAL (type) = type; diff --git a/main/gcc/tree-inline.h b/main/gcc/tree-inline.h index 2a5daaf7f61..53059da57b3 100644 --- a/main/gcc/tree-inline.h +++ b/main/gcc/tree-inline.h @@ -21,6 +21,9 @@ along with GCC; see the file COPYING3. If not see #ifndef GCC_TREE_INLINE_H #define GCC_TREE_INLINE_H +#include "hash-map.h" +#include "hash-set.h" + struct cgraph_edge; /* Indicate the desired behavior wrt call graph edges. We can either @@ -62,7 +65,7 @@ struct copy_body_data /* The map from local declarations in the inlined function to equivalents in the function into which it is being inlined. */ - struct pointer_map_t *decl_map; + hash_map *decl_map; /* Create a new decl to replace DECL in the destination function. */ tree (*copy_decl) (tree, struct copy_body_data *); @@ -79,7 +82,7 @@ struct copy_body_data /* Maps region and landing pad structures from the function being copied to duplicates created within the function we inline into. */ - struct pointer_map_t *eh_map; + hash_map *eh_map; /* We use the same mechanism do all sorts of different things. Rather than enumerating the different cases, we categorize the behavior @@ -114,7 +117,7 @@ struct copy_body_data void (*transform_lang_insert_block) (tree); /* Statements that might be possibly folded. */ - struct pointer_set_t *statements_to_fold; + hash_set *statements_to_fold; /* Entry basic block to currently copied body. */ basic_block entry_bb; @@ -130,7 +133,7 @@ struct copy_body_data equivalents in the function into which it is being inlined, where the originals have been mapped to a value rather than to a variable. */ - struct pointer_map_t *debug_map; + hash_map *debug_map; /* Cilk keywords currently need to replace some variables that ordinary nested functions do not. */ diff --git a/main/gcc/tree-loop-distribution.c b/main/gcc/tree-loop-distribution.c index bbf387d6981..7a18622d338 100644 --- a/main/gcc/tree-loop-distribution.c +++ b/main/gcc/tree-loop-distribution.c @@ -228,7 +228,7 @@ DEBUG_FUNCTION void dot_rdg (struct graph *rdg) { /* When debugging, you may want to enable the following code. */ -#if 1 +#ifdef HAVE_POPEN FILE *file = popen ("dot -Tx11", "w"); if (!file) return; diff --git a/main/gcc/tree-nested.c b/main/gcc/tree-nested.c index 185d87c07fd..7d5c039927e 100644 --- a/main/gcc/tree-nested.c +++ b/main/gcc/tree-nested.c @@ -93,9 +93,9 @@ struct nesting_info struct nesting_info *inner; struct nesting_info *next; - struct pointer_map_t *field_map; - struct pointer_map_t *var_map; - struct pointer_set_t *mem_refs; + hash_map *field_map; + hash_map *var_map; + hash_set *mem_refs; bitmap suppress_expansion; tree context; @@ -286,15 +286,13 @@ static tree lookup_field_for_decl (struct nesting_info *info, tree decl, enum insert_option insert) { - void **slot; - if (insert == NO_INSERT) { - slot = pointer_map_contains (info->field_map, decl); - return slot ? (tree) *slot : NULL_TREE; + tree *slot = info->field_map->get (decl); + return slot ? *slot : NULL_TREE; } - slot = pointer_map_insert (info->field_map, decl); + tree *slot = &info->field_map->get_or_insert (decl); if (!*slot) { tree field = make_node (FIELD_DECL); @@ -324,7 +322,7 @@ lookup_field_for_decl (struct nesting_info *info, tree decl, info->any_parm_remapped = true; } - return (tree) *slot; + return *slot; } /* Build or return the variable that holds the static chain within @@ -521,15 +519,13 @@ static tree lookup_tramp_for_decl (struct nesting_info *info, tree decl, enum insert_option insert) { - void **slot; - if (insert == NO_INSERT) { - slot = pointer_map_contains (info->var_map, decl); - return slot ? (tree) *slot : NULL_TREE; + tree *slot = info->var_map->get (decl); + return slot ? *slot : NULL_TREE; } - slot = pointer_map_insert (info->var_map, decl); + tree *slot = &info->var_map->get_or_insert (decl); if (!*slot) { tree field = make_node (FIELD_DECL); @@ -543,7 +539,7 @@ lookup_tramp_for_decl (struct nesting_info *info, tree decl, info->any_tramp_created = true; } - return (tree) *slot; + return *slot; } /* Build or return the field within the non-local frame state that holds @@ -730,9 +726,9 @@ static struct nesting_info * create_nesting_tree (struct cgraph_node *cgn) { struct nesting_info *info = XCNEW (struct nesting_info); - info->field_map = pointer_map_create (); - info->var_map = pointer_map_create (); - info->mem_refs = pointer_set_create (); + info->field_map = new hash_map; + info->var_map = new hash_map; + info->mem_refs = new hash_set; info->suppress_expansion = BITMAP_ALLOC (&nesting_info_bitmap_obstack); info->context = cgn->decl; @@ -834,12 +830,11 @@ get_nonlocal_debug_decl (struct nesting_info *info, tree decl) tree target_context; struct nesting_info *i; tree x, field, new_decl; - void **slot; - slot = pointer_map_insert (info->var_map, decl); + tree *slot = &info->var_map->get_or_insert (decl); if (*slot) - return (tree) *slot; + return *slot; target_context = decl_function_context (decl); @@ -1483,11 +1478,10 @@ static tree get_local_debug_decl (struct nesting_info *info, tree decl, tree field) { tree x, new_decl; - void **slot; - slot = pointer_map_insert (info->var_map, decl); + tree *slot = &info->var_map->get_or_insert (decl); if (*slot) - return (tree) *slot; + return *slot; /* Make sure frame_decl gets created. */ (void) get_frame_type (info); @@ -1651,7 +1645,7 @@ convert_local_reference_op (tree *tp, int *walk_subtrees, void *data) fold here, as the chain record type is not yet finalized. */ if (TREE_CODE (TREE_OPERAND (t, 0)) == ADDR_EXPR && !DECL_P (TREE_OPERAND (TREE_OPERAND (t, 0), 0))) - pointer_set_insert (info->mem_refs, tp); + info->mem_refs->add (tp); wi->val_only = save_val_only; break; @@ -2064,7 +2058,6 @@ convert_nl_goto_reference (gimple_stmt_iterator *gsi, bool *handled_ops_p, { struct nesting_info *const info = (struct nesting_info *) wi->info, *i; tree label, new_label, target_context, x, field; - void **slot; gimple call; gimple stmt = gsi_stmt (*gsi); @@ -2098,7 +2091,7 @@ convert_nl_goto_reference (gimple_stmt_iterator *gsi, bool *handled_ops_p, (hairy target-specific) non-local goto receiver code to be generated when we expand rtl. Enter this association into var_map so that we can insert the new label into the IL during a second pass. */ - slot = pointer_map_insert (i->var_map, label); + tree *slot = &i->var_map->get_or_insert (label); if (*slot == NULL) { new_label = create_artificial_label (UNKNOWN_LOCATION); @@ -2106,7 +2099,7 @@ convert_nl_goto_reference (gimple_stmt_iterator *gsi, bool *handled_ops_p, *slot = new_label; } else - new_label = (tree) *slot; + new_label = *slot; /* Build: __builtin_nl_goto(new_label, &chain->nl_goto_field). */ field = get_nl_goto_field (i); @@ -2136,7 +2129,6 @@ convert_nl_goto_receiver (gimple_stmt_iterator *gsi, bool *handled_ops_p, struct nesting_info *const info = (struct nesting_info *) wi->info; tree label, new_label; gimple_stmt_iterator tmp_gsi; - void **slot; gimple stmt = gsi_stmt (*gsi); if (gimple_code (stmt) != GIMPLE_LABEL) @@ -2147,7 +2139,7 @@ convert_nl_goto_receiver (gimple_stmt_iterator *gsi, bool *handled_ops_p, label = gimple_label_label (stmt); - slot = pointer_map_contains (info->var_map, label); + tree *slot = info->var_map->get (label); if (!slot) { *handled_ops_p = false; @@ -2513,7 +2505,7 @@ static tree nesting_copy_decl (tree decl, copy_body_data *id) { struct nesting_copy_body_data *nid = (struct nesting_copy_body_data *) id; - void **slot = pointer_map_contains (nid->root->var_map, decl); + tree *slot = nid->root->var_map->get (decl); if (slot) return (tree) *slot; @@ -2542,15 +2534,14 @@ contains_remapped_vars (tree *tp, int *walk_subtrees, void *data) { struct nesting_info *root = (struct nesting_info *) data; tree t = *tp; - void **slot; if (DECL_P (t)) { *walk_subtrees = 0; - slot = pointer_map_contains (root->var_map, t); + tree *slot = root->var_map->get (t); if (slot) - return (tree) *slot; + return *slot; } return NULL; } @@ -2580,7 +2571,7 @@ remap_vla_decls (tree block, struct nesting_info *root) && variably_modified_type_p (type, NULL))) continue; - if (pointer_map_contains (root->var_map, TREE_OPERAND (val, 0)) + if (root->var_map->get (TREE_OPERAND (val, 0)) || walk_tree (&type, contains_remapped_vars, root, NULL)) break; } @@ -2590,7 +2581,7 @@ remap_vla_decls (tree block, struct nesting_info *root) memset (&id, 0, sizeof (id)); id.cb.copy_decl = nesting_copy_decl; - id.cb.decl_map = pointer_map_create (); + id.cb.decl_map = new hash_map; id.root = root; for (; var; var = DECL_CHAIN (var)) @@ -2598,7 +2589,6 @@ remap_vla_decls (tree block, struct nesting_info *root) { struct nesting_info *i; tree newt, context; - void **slot; val = DECL_VALUE_EXPR (var); type = TREE_TYPE (var); @@ -2608,7 +2598,7 @@ remap_vla_decls (tree block, struct nesting_info *root) && variably_modified_type_p (type, NULL))) continue; - slot = pointer_map_contains (root->var_map, TREE_OPERAND (val, 0)); + tree *slot = root->var_map->get (TREE_OPERAND (val, 0)); if (!slot && !walk_tree (&type, contains_remapped_vars, root, NULL)) continue; @@ -2651,12 +2641,12 @@ remap_vla_decls (tree block, struct nesting_info *root) SET_DECL_VALUE_EXPR (var, val); } - pointer_map_destroy (id.cb.decl_map); + delete id.cb.decl_map; } /* Fold the MEM_REF *E. */ -static bool -fold_mem_refs (const void *e, void *data ATTRIBUTE_UNUSED) +bool +fold_mem_refs (tree *const &e, void *data ATTRIBUTE_UNUSED) { tree *ref_p = CONST_CAST2 (tree *, const tree *, (const tree *)e); *ref_p = fold (*ref_p); @@ -2830,7 +2820,7 @@ finalize_nesting_tree_1 (struct nesting_info *root) memset (&id, 0, sizeof (id)); id.cb.copy_decl = nesting_copy_decl; - id.cb.decl_map = pointer_map_create (); + id.cb.decl_map = new hash_map; id.root = root; for (; debug_var; debug_var = DECL_CHAIN (debug_var)) @@ -2865,7 +2855,7 @@ finalize_nesting_tree_1 (struct nesting_info *root) TYPE_NAME (newt) = remap_decl (TYPE_NAME (newt), &id.cb); } - pointer_map_destroy (id.cb.decl_map); + delete id.cb.decl_map; } scope = gimple_seq_first_stmt (gimple_body (root->context)); @@ -2878,7 +2868,7 @@ finalize_nesting_tree_1 (struct nesting_info *root) } /* Fold the rewritten MEM_REF trees. */ - pointer_set_traverse (root->mem_refs, fold_mem_refs, NULL); + root->mem_refs->traverse (NULL); /* Dump the translated tree function. */ if (dump_file) @@ -2931,9 +2921,9 @@ free_nesting_tree (struct nesting_info *root) do { next = iter_nestinfo_next (node); - pointer_map_destroy (node->var_map); - pointer_map_destroy (node->field_map); - pointer_set_destroy (node->mem_refs); + delete node->var_map; + delete node->field_map; + delete node->mem_refs; free (node); node = next; } diff --git a/main/gcc/tree-outof-ssa.c b/main/gcc/tree-outof-ssa.c index d5a635bc623..88aff5ca554 100644 --- a/main/gcc/tree-outof-ssa.c +++ b/main/gcc/tree-outof-ssa.c @@ -260,8 +260,8 @@ insert_partition_copy_on_edge (edge e, int dest, int src, source_location locus) set_curr_insn_location (locus); var = partition_to_var (SA.map, src); - seq = emit_partition_copy (SA.partition_to_pseudo[dest], - SA.partition_to_pseudo[src], + seq = emit_partition_copy (copy_rtx (SA.partition_to_pseudo[dest]), + copy_rtx (SA.partition_to_pseudo[src]), TYPE_UNSIGNED (TREE_TYPE (var)), var); @@ -274,7 +274,7 @@ insert_partition_copy_on_edge (edge e, int dest, int src, source_location locus) static void insert_value_copy_on_edge (edge e, int dest, tree src, source_location locus) { - rtx seq, x; + rtx dest_rtx, seq, x; enum machine_mode dest_mode, src_mode; int unsignedp; tree var; @@ -289,7 +289,8 @@ insert_value_copy_on_edge (edge e, int dest, tree src, source_location locus) fprintf (dump_file, "\n"); } - gcc_assert (SA.partition_to_pseudo[dest]); + dest_rtx = copy_rtx (SA.partition_to_pseudo[dest]); + gcc_assert (dest_rtx); set_location_for_edge (e); /* If a locus is provided, override the default. */ @@ -300,9 +301,9 @@ insert_value_copy_on_edge (edge e, int dest, tree src, source_location locus) var = SSA_NAME_VAR (partition_to_var (SA.map, dest)); src_mode = TYPE_MODE (TREE_TYPE (src)); - dest_mode = GET_MODE (SA.partition_to_pseudo[dest]); + dest_mode = GET_MODE (dest_rtx); gcc_assert (src_mode == TYPE_MODE (TREE_TYPE (var))); - gcc_assert (!REG_P (SA.partition_to_pseudo[dest]) + gcc_assert (!REG_P (dest_rtx) || dest_mode == promote_decl_mode (var, &unsignedp)); if (src_mode != dest_mode) @@ -312,15 +313,14 @@ insert_value_copy_on_edge (edge e, int dest, tree src, source_location locus) } else if (src_mode == BLKmode) { - x = SA.partition_to_pseudo[dest]; + x = dest_rtx; store_expr (src, x, 0, false); } else - x = expand_expr (src, SA.partition_to_pseudo[dest], - dest_mode, EXPAND_NORMAL); + x = expand_expr (src, dest_rtx, dest_mode, EXPAND_NORMAL); - if (x != SA.partition_to_pseudo[dest]) - emit_move_insn (SA.partition_to_pseudo[dest], x); + if (x != dest_rtx) + emit_move_insn (dest_rtx, x); seq = get_insns (); end_sequence (); @@ -356,7 +356,7 @@ insert_rtx_to_part_on_edge (edge e, int dest, rtx src, int unsignedsrcp, mems. Usually we give the source. As we result from SSA names the left and right size should be the same (and no WITH_SIZE_EXPR involved), so it doesn't matter. */ - seq = emit_partition_copy (SA.partition_to_pseudo[dest], + seq = emit_partition_copy (copy_rtx (SA.partition_to_pseudo[dest]), src, unsignedsrcp, partition_to_var (SA.map, dest)); @@ -390,7 +390,7 @@ insert_part_to_rtx_on_edge (edge e, rtx dest, int src, source_location locus) var = partition_to_var (SA.map, src); seq = emit_partition_copy (dest, - SA.partition_to_pseudo[src], + copy_rtx (SA.partition_to_pseudo[src]), TYPE_UNSIGNED (TREE_TYPE (var)), var); diff --git a/main/gcc/tree-pretty-print.c b/main/gcc/tree-pretty-print.c index f01071086fa..e93505c0173 100644 --- a/main/gcc/tree-pretty-print.c +++ b/main/gcc/tree-pretty-print.c @@ -27,7 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "expr.h" #include "tree-pretty-print.h" #include "hashtab.h" -#include "pointer-set.h" +#include "hash-set.h" #include "gimple-expr.h" #include "cgraph.h" #include "langhooks.h" @@ -104,14 +104,14 @@ debug_generic_stmt (tree t) DEBUG_FUNCTION void debug_tree_chain (tree t) { - struct pointer_set_t *seen = pointer_set_create (); + hash_set seen; while (t) { print_generic_expr (stderr, t, TDF_VOPS|TDF_MEMSYMS|TDF_UID); fprintf (stderr, " "); t = TREE_CHAIN (t); - if (pointer_set_insert (seen, t)) + if (seen.add (t)) { fprintf (stderr, "... [cycled back to "); print_generic_expr (stderr, t, TDF_VOPS|TDF_MEMSYMS|TDF_UID); @@ -120,8 +120,6 @@ debug_tree_chain (tree t) } } fprintf (stderr, "\n"); - - pointer_set_destroy (seen); } /* Prints declaration DECL to the FILE with details specified by FLAGS. */ diff --git a/main/gcc/tree-sra.c b/main/gcc/tree-sra.c index b80adc6f70e..461cebbdab1 100644 --- a/main/gcc/tree-sra.c +++ b/main/gcc/tree-sra.c @@ -74,11 +74,11 @@ along with GCC; see the file COPYING3. If not see #include "config.h" #include "system.h" #include "coretypes.h" +#include "hash-map.h" #include "hash-table.h" #include "alloc-pool.h" #include "tm.h" #include "tree.h" -#include "pointer-set.h" #include "basic-block.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -292,7 +292,7 @@ struct assign_link static alloc_pool link_pool; /* Base (tree) -> Vector (vec *) map. */ -static struct pointer_map_t *base_access_vec; +static hash_map > *base_access_vec; /* Candidate hash table helpers. */ @@ -520,13 +520,7 @@ access_has_replacements_p (struct access *acc) static vec * get_base_access_vector (tree base) { - void **slot; - - slot = pointer_map_contains (base_access_vec, base); - if (!slot) - return NULL; - else - return *(vec **) slot; + return base_access_vec->get (base); } /* Find an access with required OFFSET and SIZE in a subtree of accesses rooted @@ -669,24 +663,13 @@ sra_initialize (void) gcc_obstack_init (&name_obstack); access_pool = create_alloc_pool ("SRA accesses", sizeof (struct access), 16); link_pool = create_alloc_pool ("SRA links", sizeof (struct assign_link), 16); - base_access_vec = pointer_map_create (); + base_access_vec = new hash_map >; memset (&sra_stats, 0, sizeof (sra_stats)); encountered_apply_args = false; encountered_recursive_call = false; encountered_unchangable_recursive_call = false; } -/* Hook fed to pointer_map_traverse, deallocate stored vectors. */ - -static bool -delete_base_accesses (const void *key ATTRIBUTE_UNUSED, void **value, - void *data ATTRIBUTE_UNUSED) -{ - vec *access_vec = (vec *) *value; - vec_free (access_vec); - return true; -} - /* Deallocate all general structures. */ static void @@ -701,8 +684,7 @@ sra_deinitialize (void) free_alloc_pool (link_pool); obstack_free (&name_obstack, NULL); - pointer_map_traverse (base_access_vec, delete_base_accesses, NULL); - pointer_map_destroy (base_access_vec); + delete base_access_vec; } /* Remove DECL from candidates for SRA and write REASON to the dump file if @@ -851,9 +833,7 @@ mark_parm_dereference (tree base, HOST_WIDE_INT dist, gimple stmt) static struct access * create_access_1 (tree base, HOST_WIDE_INT offset, HOST_WIDE_INT size) { - vec *v; struct access *access; - void **slot; access = (struct access *) pool_alloc (access_pool); memset (access, 0, sizeof (struct access)); @@ -861,16 +841,7 @@ create_access_1 (tree base, HOST_WIDE_INT offset, HOST_WIDE_INT size) access->offset = offset; access->size = size; - slot = pointer_map_contains (base_access_vec, base); - if (slot) - v = (vec *) *slot; - else - vec_alloc (v, 32); - - v->safe_push (access); - - *((vec **) - pointer_map_insert (base_access_vec, base)) = v; + base_access_vec->get_or_insert (base).safe_push (access); return access; } @@ -3045,9 +3016,9 @@ enum assignment_mod_result { SRA_AM_NONE, /* nothing done for the stmt */ the same values as sra_modify_assign. */ static enum assignment_mod_result -sra_modify_constructor_assign (gimple *stmt, gimple_stmt_iterator *gsi) +sra_modify_constructor_assign (gimple stmt, gimple_stmt_iterator *gsi) { - tree lhs = gimple_assign_lhs (*stmt); + tree lhs = gimple_assign_lhs (stmt); struct access *acc; location_t loc; @@ -3055,23 +3026,23 @@ sra_modify_constructor_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (!acc) return SRA_AM_NONE; - if (gimple_clobber_p (*stmt)) + if (gimple_clobber_p (stmt)) { /* Remove clobbers of fully scalarized variables, otherwise do nothing. */ if (acc->grp_covered) { - unlink_stmt_vdef (*stmt); + unlink_stmt_vdef (stmt); gsi_remove (gsi, true); - release_defs (*stmt); + release_defs (stmt); return SRA_AM_REMOVED; } else return SRA_AM_NONE; } - loc = gimple_location (*stmt); - if (vec_safe_length (CONSTRUCTOR_ELTS (gimple_assign_rhs1 (*stmt))) > 0) + loc = gimple_location (stmt); + if (vec_safe_length (CONSTRUCTOR_ELTS (gimple_assign_rhs1 (stmt))) > 0) { /* I have never seen this code path trigger but if it can happen the following should handle it gracefully. */ @@ -3084,9 +3055,9 @@ sra_modify_constructor_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (acc->grp_covered) { init_subtree_with_zero (acc, gsi, false, loc); - unlink_stmt_vdef (*stmt); + unlink_stmt_vdef (stmt); gsi_remove (gsi, true); - release_defs (*stmt); + release_defs (stmt); return SRA_AM_REMOVED; } else @@ -3135,7 +3106,7 @@ contains_vce_or_bfcref_p (const_tree ref) copying. */ static enum assignment_mod_result -sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) +sra_modify_assign (gimple stmt, gimple_stmt_iterator *gsi) { struct access *lacc, *racc; tree lhs, rhs; @@ -3144,10 +3115,10 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) location_t loc; gimple_stmt_iterator orig_gsi = *gsi; - if (!gimple_assign_single_p (*stmt)) + if (!gimple_assign_single_p (stmt)) return SRA_AM_NONE; - lhs = gimple_assign_lhs (*stmt); - rhs = gimple_assign_rhs1 (*stmt); + lhs = gimple_assign_lhs (stmt); + rhs = gimple_assign_rhs1 (stmt); if (TREE_CODE (rhs) == CONSTRUCTOR) return sra_modify_constructor_assign (stmt, gsi); @@ -3156,9 +3127,9 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) || TREE_CODE (rhs) == IMAGPART_EXPR || TREE_CODE (lhs) == IMAGPART_EXPR || TREE_CODE (rhs) == BIT_FIELD_REF || TREE_CODE (lhs) == BIT_FIELD_REF) { - modify_this_stmt = sra_modify_expr (gimple_assign_rhs1_ptr (*stmt), + modify_this_stmt = sra_modify_expr (gimple_assign_rhs1_ptr (stmt), gsi, false); - modify_this_stmt |= sra_modify_expr (gimple_assign_lhs_ptr (*stmt), + modify_this_stmt |= sra_modify_expr (gimple_assign_lhs_ptr (stmt), gsi, true); return modify_this_stmt ? SRA_AM_MODIFIED : SRA_AM_NONE; } @@ -3168,11 +3139,11 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (!lacc && !racc) return SRA_AM_NONE; - loc = gimple_location (*stmt); + loc = gimple_location (stmt); if (lacc && lacc->grp_to_be_replaced) { lhs = get_access_replacement (lacc); - gimple_assign_set_lhs (*stmt, lhs); + gimple_assign_set_lhs (stmt, lhs); modify_this_stmt = true; if (lacc->grp_partial_lhs) force_gimple_rhs = true; @@ -3208,7 +3179,7 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) && !contains_bitfld_component_ref_p (lhs)) { lhs = build_ref_for_model (loc, lhs, 0, racc, gsi, false); - gimple_assign_set_lhs (*stmt, lhs); + gimple_assign_set_lhs (stmt, lhs); } else if (AGGREGATE_TYPE_P (TREE_TYPE (rhs)) && !contains_vce_or_bfcref_p (rhs)) @@ -3240,7 +3211,7 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) drhs = fold_build1_loc (loc, VIEW_CONVERT_EXPR, TREE_TYPE (dlhs), drhs); } - gimple ds = gimple_build_debug_bind (dlhs, drhs, *stmt); + gimple ds = gimple_build_debug_bind (dlhs, drhs, stmt); gsi_insert_before (gsi, ds, GSI_SAME_STMT); } @@ -3278,10 +3249,10 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) This is what the first branch does. */ if (modify_this_stmt - || gimple_has_volatile_ops (*stmt) + || gimple_has_volatile_ops (stmt) || contains_vce_or_bfcref_p (rhs) || contains_vce_or_bfcref_p (lhs) - || stmt_ends_bb_p (*stmt)) + || stmt_ends_bb_p (stmt)) { if (access_has_children_p (racc)) generate_subtree_copies (racc->first_child, rhs, racc->offset, 0, 0, @@ -3289,7 +3260,7 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (access_has_children_p (lacc)) { gimple_stmt_iterator alt_gsi = gsi_none (); - if (stmt_ends_bb_p (*stmt)) + if (stmt_ends_bb_p (stmt)) { alt_gsi = gsi_start_edge (single_non_eh_succ (gsi_bb (*gsi))); gsi = &alt_gsi; @@ -3305,11 +3276,11 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (force_gimple_rhs) rhs = force_gimple_operand_gsi (&orig_gsi, rhs, true, NULL_TREE, true, GSI_SAME_STMT); - if (gimple_assign_rhs1 (*stmt) != rhs) + if (gimple_assign_rhs1 (stmt) != rhs) { modify_this_stmt = true; gimple_assign_set_rhs_from_tree (&orig_gsi, rhs); - gcc_assert (*stmt == gsi_stmt (orig_gsi)); + gcc_assert (stmt == gsi_stmt (orig_gsi)); } return modify_this_stmt ? SRA_AM_MODIFIED : SRA_AM_NONE; @@ -3332,7 +3303,7 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) sad.top_racc = racc; sad.old_gsi = *gsi; sad.new_gsi = gsi; - sad.loc = gimple_location (*stmt); + sad.loc = gimple_location (stmt); sad.refreshed = SRA_UDH_NONE; if (lacc->grp_read && !lacc->grp_covered) @@ -3342,9 +3313,9 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (sad.refreshed != SRA_UDH_RIGHT) { gsi_next (gsi); - unlink_stmt_vdef (*stmt); + unlink_stmt_vdef (stmt); gsi_remove (&sad.old_gsi, true); - release_defs (*stmt); + release_defs (stmt); sra_stats.deleted++; return SRA_AM_REMOVED; } @@ -3357,15 +3328,15 @@ sra_modify_assign (gimple *stmt, gimple_stmt_iterator *gsi) if (dump_file) { fprintf (dump_file, "Removing load: "); - print_gimple_stmt (dump_file, *stmt, 0, 0); + print_gimple_stmt (dump_file, stmt, 0, 0); } generate_subtree_copies (racc->first_child, lhs, racc->offset, 0, 0, gsi, false, false, loc); - gcc_assert (*stmt == gsi_stmt (*gsi)); - unlink_stmt_vdef (*stmt); + gcc_assert (stmt == gsi_stmt (*gsi)); + unlink_stmt_vdef (stmt); gsi_remove (gsi, true); - release_defs (*stmt); + release_defs (stmt); sra_stats.deleted++; return SRA_AM_REMOVED; } @@ -3416,7 +3387,7 @@ sra_modify_function_body (void) break; case GIMPLE_ASSIGN: - assign_result = sra_modify_assign (&stmt, &gsi); + assign_result = sra_modify_assign (stmt, &gsi); modified |= assign_result == SRA_AM_MODIFIED; deleted = assign_result == SRA_AM_REMOVED; break; @@ -4581,17 +4552,15 @@ replace_removed_params_ssa_names (gimple stmt, return true; } -/* If the statement pointed to by STMT_PTR contains any expressions that need - to replaced with a different one as noted by ADJUSTMENTS, do so. Handle any - potential type incompatibilities (GSI is used to accommodate conversion - statements and must point to the statement). Return true iff the statement - was modified. */ +/* If the statement STMT contains any expressions that need to replaced with a + different one as noted by ADJUSTMENTS, do so. Handle any potential type + incompatibilities (GSI is used to accommodate conversion statements and must + point to the statement). Return true iff the statement was modified. */ static bool -sra_ipa_modify_assign (gimple *stmt_ptr, gimple_stmt_iterator *gsi, +sra_ipa_modify_assign (gimple stmt, gimple_stmt_iterator *gsi, ipa_parm_adjustment_vec adjustments) { - gimple stmt = *stmt_ptr; tree *lhs_p, *rhs_p; bool any; @@ -4678,7 +4647,7 @@ ipa_sra_modify_function_body (ipa_parm_adjustment_vec adjustments) break; case GIMPLE_ASSIGN: - modified |= sra_ipa_modify_assign (&stmt, &gsi, adjustments); + modified |= sra_ipa_modify_assign (stmt, &gsi, adjustments); modified |= replace_removed_params_ssa_names (stmt, adjustments); break; diff --git a/main/gcc/tree-ssa-ccp.c b/main/gcc/tree-ssa-ccp.c index 283bb1283e8..a90f7089190 100644 --- a/main/gcc/tree-ssa-ccp.c +++ b/main/gcc/tree-ssa-ccp.c @@ -2655,7 +2655,7 @@ pass_fold_builtins::execute (function *fun) for (i = gsi_start_bb (bb); !gsi_end_p (i); ) { gimple stmt, old_stmt; - tree callee, result; + tree callee; enum built_in_function fcode; stmt = gsi_stmt (i); @@ -2680,62 +2680,69 @@ pass_fold_builtins::execute (function *fun) gsi_next (&i); continue; } + callee = gimple_call_fndecl (stmt); if (!callee || DECL_BUILT_IN_CLASS (callee) != BUILT_IN_NORMAL) { gsi_next (&i); continue; } - fcode = DECL_FUNCTION_CODE (callee); - - result = gimple_fold_builtin (stmt); - if (result) - gimple_remove_stmt_histograms (fun, stmt); + fcode = DECL_FUNCTION_CODE (callee); + if (fold_stmt (&i)) + ; + else + { + tree result = NULL_TREE; + switch (DECL_FUNCTION_CODE (callee)) + { + case BUILT_IN_CONSTANT_P: + /* Resolve __builtin_constant_p. If it hasn't been + folded to integer_one_node by now, it's fairly + certain that the value simply isn't constant. */ + result = integer_zero_node; + break; - if (!result) - switch (DECL_FUNCTION_CODE (callee)) - { - case BUILT_IN_CONSTANT_P: - /* Resolve __builtin_constant_p. If it hasn't been - folded to integer_one_node by now, it's fairly - certain that the value simply isn't constant. */ - result = integer_zero_node; - break; + case BUILT_IN_ASSUME_ALIGNED: + /* Remove __builtin_assume_aligned. */ + result = gimple_call_arg (stmt, 0); + break; - case BUILT_IN_ASSUME_ALIGNED: - /* Remove __builtin_assume_aligned. */ - result = gimple_call_arg (stmt, 0); - break; + case BUILT_IN_STACK_RESTORE: + result = optimize_stack_restore (i); + if (result) + break; + gsi_next (&i); + continue; - case BUILT_IN_STACK_RESTORE: - result = optimize_stack_restore (i); - if (result) + case BUILT_IN_UNREACHABLE: + if (optimize_unreachable (i)) + cfg_changed = true; break; - gsi_next (&i); - continue; - case BUILT_IN_UNREACHABLE: - if (optimize_unreachable (i)) - cfg_changed = true; - break; + case BUILT_IN_VA_START: + case BUILT_IN_VA_END: + case BUILT_IN_VA_COPY: + /* These shouldn't be folded before pass_stdarg. */ + result = optimize_stdarg_builtin (stmt); + if (result) + break; + /* FALLTHRU */ - case BUILT_IN_VA_START: - case BUILT_IN_VA_END: - case BUILT_IN_VA_COPY: - /* These shouldn't be folded before pass_stdarg. */ - result = optimize_stdarg_builtin (stmt); - if (result) - break; - /* FALLTHRU */ + default:; + } - default: - gsi_next (&i); - continue; - } + if (!result) + { + gsi_next (&i); + continue; + } - if (result == NULL_TREE) - break; + if (!update_call_from_tree (&i, result)) + gimplify_and_update_call_from_tree (&i, result); + } + + todoflags |= TODO_update_address_taken; if (dump_file && (dump_flags & TDF_DETAILS)) { @@ -2744,12 +2751,6 @@ pass_fold_builtins::execute (function *fun) } old_stmt = stmt; - if (!update_call_from_tree (&i, result)) - { - gimplify_and_update_call_from_tree (&i, result); - todoflags |= TODO_update_address_taken; - } - stmt = gsi_stmt (i); update_stmt (stmt); diff --git a/main/gcc/tree-ssa-dom.c b/main/gcc/tree-ssa-dom.c index c4ec4e5415c..fec386e3152 100644 --- a/main/gcc/tree-ssa-dom.c +++ b/main/gcc/tree-ssa-dom.c @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "tm_p.h" #include "basic-block.h" #include "cfgloop.h" +#include "inchash.h" #include "function.h" #include "gimple-pretty-print.h" #include "tree-ssa-alias.h" @@ -54,6 +55,7 @@ along with GCC; see the file COPYING3. If not see #include "params.h" #include "tree-ssa-threadedge.h" #include "tree-ssa-dom.h" +#include "inchash.h" /* This file implements optimizations on the dominator tree. */ @@ -556,45 +558,42 @@ hashable_expr_equal_p (const struct hashable_expr *expr0, } /* Generate a hash value for a pair of expressions. This can be used - iteratively by passing a previous result as the VAL argument. + iteratively by passing a previous result in HSTATE. The same hash value is always returned for a given pair of expressions, regardless of the order in which they are presented. This is useful in hashing the operands of commutative functions. */ -static hashval_t -iterative_hash_exprs_commutative (const_tree t1, - const_tree t2, hashval_t val) +namespace inchash { - hashval_t one = iterative_hash_expr (t1, 0); - hashval_t two = iterative_hash_expr (t2, 0); - hashval_t t; - if (one > two) - t = one, one = two, two = t; - val = iterative_hash_hashval_t (one, val); - val = iterative_hash_hashval_t (two, val); +static void +add_expr_commutative (const_tree t1, const_tree t2, hash &hstate) +{ + hash one, two; - return val; + inchash::add_expr (t1, one); + inchash::add_expr (t2, two); + hstate.add_commutative (one, two); } /* Compute a hash value for a hashable_expr value EXPR and a previously accumulated hash value VAL. If two hashable_expr values compare equal with hashable_expr_equal_p, they must hash to the same value, given an identical value of VAL. - The logic is intended to follow iterative_hash_expr in tree.c. */ + The logic is intended to follow inchash::add_expr in tree.c. */ -static hashval_t -iterative_hash_hashable_expr (const struct hashable_expr *expr, hashval_t val) +static void +add_hashable_expr (const struct hashable_expr *expr, hash &hstate) { switch (expr->kind) { case EXPR_SINGLE: - val = iterative_hash_expr (expr->ops.single.rhs, val); + inchash::add_expr (expr->ops.single.rhs, hstate); break; case EXPR_UNARY: - val = iterative_hash_object (expr->ops.unary.op, val); + hstate.add_object (expr->ops.unary.op); /* Make sure to include signedness in the hash computation. Don't hash the type, that can lead to having nodes which @@ -602,34 +601,34 @@ iterative_hash_hashable_expr (const struct hashable_expr *expr, hashval_t val) have different hash codes. */ if (CONVERT_EXPR_CODE_P (expr->ops.unary.op) || expr->ops.unary.op == NON_LVALUE_EXPR) - val += TYPE_UNSIGNED (expr->type); + hstate.add_int (TYPE_UNSIGNED (expr->type)); - val = iterative_hash_expr (expr->ops.unary.opnd, val); + inchash::add_expr (expr->ops.unary.opnd, hstate); break; case EXPR_BINARY: - val = iterative_hash_object (expr->ops.binary.op, val); + hstate.add_object (expr->ops.binary.op); if (commutative_tree_code (expr->ops.binary.op)) - val = iterative_hash_exprs_commutative (expr->ops.binary.opnd0, - expr->ops.binary.opnd1, val); + inchash::add_expr_commutative (expr->ops.binary.opnd0, + expr->ops.binary.opnd1, hstate); else { - val = iterative_hash_expr (expr->ops.binary.opnd0, val); - val = iterative_hash_expr (expr->ops.binary.opnd1, val); + inchash::add_expr (expr->ops.binary.opnd0, hstate); + inchash::add_expr (expr->ops.binary.opnd1, hstate); } break; case EXPR_TERNARY: - val = iterative_hash_object (expr->ops.ternary.op, val); + hstate.add_object (expr->ops.ternary.op); if (commutative_ternary_tree_code (expr->ops.ternary.op)) - val = iterative_hash_exprs_commutative (expr->ops.ternary.opnd0, - expr->ops.ternary.opnd1, val); + inchash::add_expr_commutative (expr->ops.ternary.opnd0, + expr->ops.ternary.opnd1, hstate); else { - val = iterative_hash_expr (expr->ops.ternary.opnd0, val); - val = iterative_hash_expr (expr->ops.ternary.opnd1, val); + inchash::add_expr (expr->ops.ternary.opnd0, hstate); + inchash::add_expr (expr->ops.ternary.opnd1, hstate); } - val = iterative_hash_expr (expr->ops.ternary.opnd2, val); + inchash::add_expr (expr->ops.ternary.opnd2, hstate); break; case EXPR_CALL: @@ -638,15 +637,14 @@ iterative_hash_hashable_expr (const struct hashable_expr *expr, hashval_t val) enum tree_code code = CALL_EXPR; gimple fn_from; - val = iterative_hash_object (code, val); + hstate.add_object (code); fn_from = expr->ops.call.fn_from; if (gimple_call_internal_p (fn_from)) - val = iterative_hash_hashval_t - ((hashval_t) gimple_call_internal_fn (fn_from), val); + hstate.merge_hash ((hashval_t) gimple_call_internal_fn (fn_from)); else - val = iterative_hash_expr (gimple_call_fn (fn_from), val); + inchash::add_expr (gimple_call_fn (fn_from), hstate); for (i = 0; i < expr->ops.call.nargs; i++) - val = iterative_hash_expr (expr->ops.call.args[i], val); + inchash::add_expr (expr->ops.call.args[i], hstate); } break; @@ -655,15 +653,15 @@ iterative_hash_hashable_expr (const struct hashable_expr *expr, hashval_t val) size_t i; for (i = 0; i < expr->ops.phi.nargs; i++) - val = iterative_hash_expr (expr->ops.phi.args[i], val); + inchash::add_expr (expr->ops.phi.args[i], hstate); } break; default: gcc_unreachable (); } +} - return val; } /* Print a diagnostic dump of an expression hash table entry. */ @@ -2598,24 +2596,24 @@ avail_expr_hash (const void *p) gimple stmt = ((const struct expr_hash_elt *)p)->stmt; const struct hashable_expr *expr = &((const struct expr_hash_elt *)p)->expr; tree vuse; - hashval_t val = 0; + inchash::hash hstate; - val = iterative_hash_hashable_expr (expr, val); + inchash::add_hashable_expr (expr, hstate); /* If the hash table entry is not associated with a statement, then we can just hash the expression and not worry about virtual operands and such. */ if (!stmt) - return val; + return hstate.end (); /* Add the SSA version numbers of the vuse operand. This is important because compound variables like arrays are not renamed in the operands. Rather, the rename is done on the virtual variable representing all the elements of the array. */ if ((vuse = gimple_vuse (stmt))) - val = iterative_hash_expr (vuse, val); + inchash::add_expr (vuse, hstate); - return val; + return hstate.end (); } /* PHI-ONLY copy and constant propagation. This pass is meant to clean diff --git a/main/gcc/tree-ssa-loop-im.c b/main/gcc/tree-ssa-loop-im.c index c614978cbe1..0cbb3ae17a2 100644 --- a/main/gcc/tree-ssa-loop-im.c +++ b/main/gcc/tree-ssa-loop-im.c @@ -26,6 +26,7 @@ along with GCC; see the file COPYING3. If not see #include "basic-block.h" #include "gimple-pretty-print.h" #include "pointer-set.h" +#include "hash-map.h" #include "hash-table.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -103,7 +104,7 @@ struct lim_aux_data /* Maps statements to their lim_aux_data. */ -static struct pointer_map_t *lim_aux_data_map; +static hash_map *lim_aux_data_map; /* Description of a memory reference location. */ @@ -225,20 +226,20 @@ static bool ref_indep_loop_p (struct loop *, mem_ref_p); static struct lim_aux_data * init_lim_data (gimple stmt) { - void **p = pointer_map_insert (lim_aux_data_map, stmt); + lim_aux_data *p = XCNEW (struct lim_aux_data); + lim_aux_data_map->put (stmt, p); - *p = XCNEW (struct lim_aux_data); - return (struct lim_aux_data *) *p; + return p; } static struct lim_aux_data * get_lim_data (gimple stmt) { - void **p = pointer_map_contains (lim_aux_data_map, stmt); + lim_aux_data **p = lim_aux_data_map->get (stmt); if (!p) return NULL; - return (struct lim_aux_data *) *p; + return *p; } /* Releases the memory occupied by DATA. */ @@ -253,11 +254,11 @@ free_lim_aux_data (struct lim_aux_data *data) static void clear_lim_data (gimple stmt) { - void **p = pointer_map_contains (lim_aux_data_map, stmt); + lim_aux_data **p = lim_aux_data_map->get (stmt); if (!p) return; - free_lim_aux_data ((struct lim_aux_data *) *p); + free_lim_aux_data (*p); *p = NULL; } @@ -2429,7 +2430,7 @@ tree_ssa_lim_initialize (void) bitmap_obstack_initialize (&lim_bitmap_obstack); gcc_obstack_init (&mem_ref_obstack); - lim_aux_data_map = pointer_map_create (); + lim_aux_data_map = new hash_map; if (flag_tm) compute_transaction_bits (); @@ -2484,7 +2485,7 @@ tree_ssa_lim_finalize (void) SET_ALWAYS_EXECUTED_IN (bb, NULL); bitmap_obstack_release (&lim_bitmap_obstack); - pointer_map_destroy (lim_aux_data_map); + delete lim_aux_data_map; delete memory_accesses.refs; memory_accesses.refs = NULL; diff --git a/main/gcc/tree-ssa-loop-ivopts.c b/main/gcc/tree-ssa-loop-ivopts.c index 3b4a6cdf24c..158a0814d69 100644 --- a/main/gcc/tree-ssa-loop-ivopts.c +++ b/main/gcc/tree-ssa-loop-ivopts.c @@ -70,7 +70,7 @@ along with GCC; see the file COPYING3. If not see #include "tm_p.h" #include "basic-block.h" #include "gimple-pretty-print.h" -#include "pointer-set.h" +#include "hash-map.h" #include "hash-table.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -293,7 +293,7 @@ struct ivopts_data struct loop *current_loop; /* Numbers of iterations for all exits of the current loop. */ - struct pointer_map_t *niters; + hash_map *niters; /* Number of registers used in it. */ unsigned regs_used; @@ -814,15 +814,15 @@ static struct tree_niter_desc * niter_for_exit (struct ivopts_data *data, edge exit) { struct tree_niter_desc *desc; - void **slot; + tree_niter_desc **slot; if (!data->niters) { - data->niters = pointer_map_create (); + data->niters = new hash_map; slot = NULL; } else - slot = pointer_map_contains (data->niters, exit); + slot = data->niters->get (exit); if (!slot) { @@ -837,11 +837,10 @@ niter_for_exit (struct ivopts_data *data, edge exit) XDELETE (desc); desc = NULL; } - slot = pointer_map_insert (data->niters, exit); - *slot = desc; + data->niters->put (exit, desc); } else - desc = (struct tree_niter_desc *) *slot; + desc = *slot; return desc; } @@ -6704,15 +6703,12 @@ remove_unused_ivs (struct ivopts_data *data) } /* Frees memory occupied by struct tree_niter_desc in *VALUE. Callback - for pointer_map_traverse. */ + for hash_map::traverse. */ -static bool -free_tree_niter_desc (const void *key ATTRIBUTE_UNUSED, void **value, - void *data ATTRIBUTE_UNUSED) +bool +free_tree_niter_desc (edge const &, tree_niter_desc *const &value, void *) { - struct tree_niter_desc *const niter = (struct tree_niter_desc *) *value; - - free (niter); + free (value); return true; } @@ -6727,8 +6723,8 @@ free_loop_data (struct ivopts_data *data) if (data->niters) { - pointer_map_traverse (data->niters, free_tree_niter_desc, NULL); - pointer_map_destroy (data->niters); + data->niters->traverse (NULL); + delete data->niters; data->niters = NULL; } diff --git a/main/gcc/tree-ssa-loop-niter.c b/main/gcc/tree-ssa-loop-niter.c index 36d68a884bb..83c1b195843 100644 --- a/main/gcc/tree-ssa-loop-niter.c +++ b/main/gcc/tree-ssa-loop-niter.c @@ -28,6 +28,7 @@ along with GCC; see the file COPYING3. If not see #include "basic-block.h" #include "gimple-pretty-print.h" #include "intl.h" +#include "hash-set.h" #include "pointer-set.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -3281,7 +3282,7 @@ discover_iteration_bound_by_body_walk (struct loop *loop) static void maybe_lower_iteration_bound (struct loop *loop) { - pointer_set_t *not_executed_last_iteration = NULL; + hash_set *not_executed_last_iteration = NULL; struct nb_iter_bound *elt; bool found_exit = false; vec queue = vNULL; @@ -3300,8 +3301,8 @@ maybe_lower_iteration_bound (struct loop *loop) && wi::ltu_p (elt->bound, loop->nb_iterations_upper_bound)) { if (!not_executed_last_iteration) - not_executed_last_iteration = pointer_set_create (); - pointer_set_insert (not_executed_last_iteration, elt->stmt); + not_executed_last_iteration = new hash_set; + not_executed_last_iteration->add (elt->stmt); } } if (!not_executed_last_iteration) @@ -3327,7 +3328,7 @@ maybe_lower_iteration_bound (struct loop *loop) for (gsi = gsi_start_bb (bb); !gsi_end_p (gsi); gsi_next (&gsi)) { gimple stmt = gsi_stmt (gsi); - if (pointer_set_contains (not_executed_last_iteration, stmt)) + if (not_executed_last_iteration->contains (stmt)) { stmt_found = true; break; @@ -3376,7 +3377,7 @@ maybe_lower_iteration_bound (struct loop *loop) } BITMAP_FREE (visited); queue.release (); - pointer_set_destroy (not_executed_last_iteration); + delete not_executed_last_iteration; } /* Records estimates on numbers of iterations of LOOP. If USE_UNDEFINED_P diff --git a/main/gcc/tree-ssa-loop.c b/main/gcc/tree-ssa-loop.c index 7c52748f760..d0c9980b35b 100644 --- a/main/gcc/tree-ssa-loop.c +++ b/main/gcc/tree-ssa-loop.c @@ -168,7 +168,7 @@ public: }; // class pass_tree_loop_init unsigned int -pass_tree_loop_init::execute (function *fun) +pass_tree_loop_init::execute (function *fun ATTRIBUTE_UNUSED) { loop_optimizer_init (LOOPS_NORMAL | LOOPS_HAVE_RECORDED_EXITS); @@ -178,9 +178,6 @@ pass_tree_loop_init::execute (function *fun) regions into reducible. */ scev_initialize (); - if (number_of_loops (fun) <= 1) - return 0; - return 0; } diff --git a/main/gcc/tree-ssa-phiopt.c b/main/gcc/tree-ssa-phiopt.c index 052d76014a6..3185d9a6153 100644 --- a/main/gcc/tree-ssa-phiopt.c +++ b/main/gcc/tree-ssa-phiopt.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "tm_p.h" #include "basic-block.h" +#include "hash-set.h" #include "pointer-set.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -72,9 +73,9 @@ static bool abs_replacement (basic_block, basic_block, static bool neg_replacement (basic_block, basic_block, edge, edge, gimple, tree, tree); static bool cond_store_replacement (basic_block, basic_block, edge, edge, - struct pointer_set_t *); + hash_set *); static bool cond_if_else_store_replacement (basic_block, basic_block, basic_block); -static struct pointer_set_t * get_non_trapping (void); +static hash_set * get_non_trapping (); static void replace_phi_edge_with_variable (basic_block, edge, gimple, tree); static void hoist_adjacent_loads (basic_block, basic_block, basic_block, basic_block); @@ -176,7 +177,7 @@ tree_ssa_phiopt_worker (bool do_store_elim, bool do_hoist_loads) basic_block *bb_order; unsigned n, i; bool cfgchanged = false; - struct pointer_set_t *nontrap = 0; + hash_set *nontrap = 0; if (do_store_elim) /* Calculate the set of non-trapping memory accesses. */ @@ -363,7 +364,7 @@ tree_ssa_phiopt_worker (bool do_store_elim, bool do_hoist_loads) free (bb_order); if (do_store_elim) - pointer_set_destroy (nontrap); + delete nontrap; /* If the CFG has changed, we should cleanup the CFG. */ if (cfgchanged && do_store_elim) { @@ -1469,7 +1470,7 @@ ssa_names_hasher::equal (const value_type *n1, const compare_type *n2) class nontrapping_dom_walker : public dom_walker { public: - nontrapping_dom_walker (cdi_direction direction, pointer_set_t *ps) + nontrapping_dom_walker (cdi_direction direction, hash_set *ps) : dom_walker (direction), m_nontrapping (ps), m_seen_ssa_names (128) {} virtual void before_dom_children (basic_block); @@ -1484,7 +1485,7 @@ private: the RHS. */ void add_or_mark_expr (basic_block, tree, bool); - pointer_set_t *m_nontrapping; + hash_set *m_nontrapping; /* The hash table for remembering what we've seen. */ hash_table m_seen_ssa_names; @@ -1572,7 +1573,7 @@ nontrapping_dom_walker::add_or_mark_expr (basic_block bb, tree exp, bool store) then we can't trap. */ if (found_bb && (((size_t)found_bb->aux) & 1) == 1) { - pointer_set_insert (m_nontrapping, exp); + m_nontrapping->add (exp); } else { @@ -1601,11 +1602,11 @@ nontrapping_dom_walker::add_or_mark_expr (basic_block bb, tree exp, bool store) It will do a dominator walk over the whole function, and it will make use of the bb->aux pointers. It returns a set of trees (the MEM_REFs itself) which can't trap. */ -static struct pointer_set_t * +static hash_set * get_non_trapping (void) { nt_call_phase = 0; - pointer_set_t *nontrap = pointer_set_create (); + hash_set *nontrap = new hash_set; /* We're going to do a dominator walk, so ensure that we have dominance information. */ calculate_dominance_info (CDI_DOMINATORS); @@ -1634,7 +1635,7 @@ get_non_trapping (void) static bool cond_store_replacement (basic_block middle_bb, basic_block join_bb, - edge e0, edge e1, struct pointer_set_t *nontrap) + edge e0, edge e1, hash_set *nontrap) { gimple assign = last_and_only_stmt (middle_bb); tree lhs, rhs, name, name2; @@ -1659,7 +1660,7 @@ cond_store_replacement (basic_block middle_bb, basic_block join_bb, /* Prove that we can move the store down. We could also check TREE_THIS_NOTRAP here, but in that case we also could move stores, whose value is not available readily, which we want to avoid. */ - if (!pointer_set_contains (nontrap, lhs)) + if (!nontrap->contains (lhs)) return false; /* Now we've checked the constraints, so do the transformation: diff --git a/main/gcc/tree-ssa-pre.c b/main/gcc/tree-ssa-pre.c index 128c215954c..8b4d2badb6f 100644 --- a/main/gcc/tree-ssa-pre.c +++ b/main/gcc/tree-ssa-pre.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include "basic-block.h" #include "gimple-pretty-print.h" #include "tree-inline.h" +#include "inchash.h" #include "hash-table.h" #include "tree-ssa-alias.h" #include "internal-fn.h" diff --git a/main/gcc/tree-ssa-reassoc.c b/main/gcc/tree-ssa-reassoc.c index f9bd9a446c6..2e8337c8e6f 100644 --- a/main/gcc/tree-ssa-reassoc.c +++ b/main/gcc/tree-ssa-reassoc.c @@ -30,7 +30,7 @@ along with GCC; see the file COPYING3. If not see #include "basic-block.h" #include "gimple-pretty-print.h" #include "tree-inline.h" -#include "pointer-set.h" +#include "hash-map.h" #include "tree-ssa-alias.h" #include "internal-fn.h" #include "gimple-fold.h" @@ -216,7 +216,7 @@ static int next_operand_entry_id; static long *bb_rank; /* Operand->rank hashtable. */ -static struct pointer_map_t *operand_rank; +static hash_map *operand_rank; /* Forward decls. */ static long get_rank (tree); @@ -362,8 +362,8 @@ propagate_rank (long rank, tree op) static inline long find_operand_rank (tree e) { - void **slot = pointer_map_contains (operand_rank, e); - return slot ? (long) (intptr_t) *slot : -1; + long *slot = operand_rank->get (e); + return slot ? *slot : -1; } /* Insert {E,RANK} into the operand rank hashtable. */ @@ -371,11 +371,8 @@ find_operand_rank (tree e) static inline void insert_operand_rank (tree e, long rank) { - void **slot; gcc_assert (rank > 0); - slot = pointer_map_insert (operand_rank, e); - gcc_assert (!*slot); - *slot = (void *) (intptr_t) rank; + gcc_assert (!operand_rank->put (e, rank)); } /* Given an expression E, return the rank of the expression. */ @@ -4635,7 +4632,7 @@ init_reassoc (void) deeper loops come later. */ pre_and_rev_post_order_compute (NULL, bbs, false); bb_rank = XCNEWVEC (long, last_basic_block_for_fn (cfun)); - operand_rank = pointer_map_create (); + operand_rank = new hash_map; /* Give each default definition a distinct rank. This includes parameters and the static chain. Walk backwards over all @@ -4676,7 +4673,7 @@ fini_reassoc (void) statistics_counter_event (cfun, "Built-in powi calls created", reassociate_stats.pows_created); - pointer_map_destroy (operand_rank); + delete operand_rank; free_alloc_pool (operand_entry_pool); free (bb_rank); plus_negates.release (); diff --git a/main/gcc/tree-ssa-sccvn.c b/main/gcc/tree-ssa-sccvn.c index 139ac3bbc72..ec0bf6b402d 100644 --- a/main/gcc/tree-ssa-sccvn.c +++ b/main/gcc/tree-ssa-sccvn.c @@ -30,6 +30,7 @@ along with GCC; see the file COPYING3. If not see #include "hash-table.h" #include "tree-ssa-alias.h" #include "internal-fn.h" +#include "inchash.h" #include "gimple-fold.h" #include "tree-eh.h" #include "gimple-expr.h" @@ -593,17 +594,16 @@ value_id_constant_p (unsigned int v) /* Compute the hash for a reference operand VRO1. */ -static hashval_t -vn_reference_op_compute_hash (const vn_reference_op_t vro1, hashval_t result) +static void +vn_reference_op_compute_hash (const vn_reference_op_t vro1, inchash::hash &hstate) { - result = iterative_hash_hashval_t (vro1->opcode, result); + hstate.add_int (vro1->opcode); if (vro1->op0) - result = iterative_hash_expr (vro1->op0, result); + inchash::add_expr (vro1->op0, hstate); if (vro1->op1) - result = iterative_hash_expr (vro1->op1, result); + inchash::add_expr (vro1->op1, hstate); if (vro1->op2) - result = iterative_hash_expr (vro1->op2, result); - return result; + inchash::add_expr (vro1->op2, hstate); } /* Compute a hash for the reference operation VR1 and return it. */ @@ -611,7 +611,8 @@ vn_reference_op_compute_hash (const vn_reference_op_t vro1, hashval_t result) hashval_t vn_reference_compute_hash (const vn_reference_t vr1) { - hashval_t result = 0; + inchash::hash hstate; + hashval_t result; int i; vn_reference_op_t vro; HOST_WIDE_INT off = -1; @@ -633,7 +634,7 @@ vn_reference_compute_hash (const vn_reference_t vr1) { if (off != -1 && off != 0) - result = iterative_hash_hashval_t (off, result); + hstate.add_int (off); off = -1; if (deref && vro->opcode == ADDR_EXPR) @@ -641,14 +642,16 @@ vn_reference_compute_hash (const vn_reference_t vr1) if (vro->op0) { tree op = TREE_OPERAND (vro->op0, 0); - result = iterative_hash_hashval_t (TREE_CODE (op), result); - result = iterative_hash_expr (op, result); + hstate.add_int (TREE_CODE (op)); + inchash::add_expr (op, hstate); } } else - result = vn_reference_op_compute_hash (vro, result); + vn_reference_op_compute_hash (vro, hstate); } } + result = hstate.end (); + /* ??? We would ICE later if we hash instead of adding that in. */ if (vr1->vuse) result += SSA_NAME_VERSION (vr1->vuse); @@ -2235,7 +2238,7 @@ vn_reference_insert_pieces (tree vuse, alias_set_type set, tree type, hashval_t vn_nary_op_compute_hash (const vn_nary_op_t vno1) { - hashval_t hash; + inchash::hash hstate; unsigned i; for (i = 0; i < vno1->length; ++i) @@ -2251,11 +2254,11 @@ vn_nary_op_compute_hash (const vn_nary_op_t vno1) vno1->op[1] = temp; } - hash = iterative_hash_hashval_t (vno1->opcode, 0); + hstate.add_int (vno1->opcode); for (i = 0; i < vno1->length; ++i) - hash = iterative_hash_expr (vno1->op[i], hash); + inchash::add_expr (vno1->op[i], hstate); - return hash; + return hstate.end (); } /* Compare nary operations VNO1 and VNO2 and return true if they are @@ -2535,26 +2538,24 @@ vn_nary_op_insert_stmt (gimple stmt, tree result) static inline hashval_t vn_phi_compute_hash (vn_phi_t vp1) { - hashval_t result; + inchash::hash hstate (vp1->block->index); int i; tree phi1op; tree type; - result = vp1->block->index; - /* If all PHI arguments are constants we need to distinguish the PHI node via its type. */ type = vp1->type; - result += vn_hash_type (type); + hstate.merge_hash (vn_hash_type (type)); FOR_EACH_VEC_ELT (vp1->phiargs, i, phi1op) { if (phi1op == VN_TOP) continue; - result = iterative_hash_expr (phi1op, result); + inchash::add_expr (phi1op, hstate); } - return result; + return hstate.end (); } /* Compare two phi entries for equality, ignoring VN_TOP arguments. */ diff --git a/main/gcc/tree-ssa-sccvn.h b/main/gcc/tree-ssa-sccvn.h index f52783a68cf..84ea278f846 100644 --- a/main/gcc/tree-ssa-sccvn.h +++ b/main/gcc/tree-ssa-sccvn.h @@ -140,8 +140,10 @@ vn_hash_type (tree type) static inline hashval_t vn_hash_constant_with_type (tree constant) { - return (iterative_hash_expr (constant, 0) - + vn_hash_type (TREE_TYPE (constant))); + inchash::hash hstate; + inchash::add_expr (constant, hstate); + hstate.merge_hash (vn_hash_type (TREE_TYPE (constant))); + return hstate.end (); } /* Compare the constants C1 and C2 with distinguishing type incompatible diff --git a/main/gcc/tree-ssa-structalias.c b/main/gcc/tree-ssa-structalias.c index 1879fc0b8ff..521d7786376 100644 --- a/main/gcc/tree-ssa-structalias.c +++ b/main/gcc/tree-ssa-structalias.c @@ -319,7 +319,7 @@ static inline bool type_can_have_subvars (const_tree); static alloc_pool variable_info_pool; /* Map varinfo to final pt_solution. */ -static pointer_map_t *final_solutions; +static hash_map *final_solutions; struct obstack final_solutions_obstack; /* Table of variable info structures for constraint variables. @@ -393,19 +393,19 @@ new_var_info (tree t, const char *name) /* A map mapping call statements to per-stmt variables for uses and clobbers specific to the call. */ -static struct pointer_map_t *call_stmt_vars; +static hash_map *call_stmt_vars; /* Lookup or create the variable for the call statement CALL. */ static varinfo_t get_call_vi (gimple call) { - void **slot_p; varinfo_t vi, vi2; - slot_p = pointer_map_insert (call_stmt_vars, call); - if (*slot_p) - return (varinfo_t) *slot_p; + bool existed; + varinfo_t *slot_p = &call_stmt_vars->get_or_insert (call, &existed); + if (existed) + return *slot_p; vi = new_var_info (NULL_TREE, "CALLUSED"); vi->offset = 0; @@ -421,7 +421,7 @@ get_call_vi (gimple call) vi->next = vi2->id; - *slot_p = (void *) vi; + *slot_p = vi; return vi; } @@ -431,11 +431,9 @@ get_call_vi (gimple call) static varinfo_t lookup_call_use_vi (gimple call) { - void **slot_p; - - slot_p = pointer_map_contains (call_stmt_vars, call); + varinfo_t *slot_p = call_stmt_vars->get (call); if (slot_p) - return (varinfo_t) *slot_p; + return *slot_p; return NULL; } @@ -2794,7 +2792,7 @@ solve_graph (constraint_graph_t graph) } /* Map from trees to variable infos. */ -static struct pointer_map_t *vi_for_tree; +static hash_map *vi_for_tree; /* Insert ID as the variable id for tree T in the vi_for_tree map. */ @@ -2802,10 +2800,8 @@ static struct pointer_map_t *vi_for_tree; static void insert_vi_for_tree (tree t, varinfo_t vi) { - void **slot = pointer_map_insert (vi_for_tree, t); gcc_assert (vi); - gcc_assert (*slot == NULL); - *slot = vi; + gcc_assert (!vi_for_tree->put (t, vi)); } /* Find the variable info for tree T in VI_FOR_TREE. If T does not @@ -2814,11 +2810,11 @@ insert_vi_for_tree (tree t, varinfo_t vi) static varinfo_t lookup_vi_for_tree (tree t) { - void **slot = pointer_map_contains (vi_for_tree, t); + varinfo_t *slot = vi_for_tree->get (t); if (slot == NULL) return NULL; - return (varinfo_t) *slot; + return *slot; } /* Return a printable name for DECL */ @@ -2876,11 +2872,11 @@ alias_get_name (tree decl) static varinfo_t get_vi_for_tree (tree t) { - void **slot = pointer_map_contains (vi_for_tree, t); + varinfo_t *slot = vi_for_tree->get (t); if (slot == NULL) return get_varinfo (create_variable_info_for (t, alias_get_name (t))); - return (varinfo_t) *slot; + return *slot; } /* Get a scalar constraint expression for a new temporary variable. */ @@ -5650,6 +5646,7 @@ create_variable_info_for_1 (tree decl, const char *name) auto_vec fieldstack; fieldoff_s *fo; unsigned int i; + varpool_node *vnode; if (!declsize || !tree_fits_uhwi_p (declsize)) @@ -5671,7 +5668,8 @@ create_variable_info_for_1 (tree decl, const char *name) in IPA mode. Else we'd have to parse arbitrary initializers. */ && !(in_ipa_mode && is_global_var (decl) - && varpool_node::get (decl)->get_constructor ())) + && (vnode = varpool_node::get (decl)) + && vnode->get_constructor ())) { fieldoff_s *fo = NULL; bool notokay = false; @@ -6075,7 +6073,6 @@ find_what_var_points_to (varinfo_t orig_vi) bitmap finished_solution; bitmap result; varinfo_t vi; - void **slot; struct pt_solution *pt; /* This variable may have been collapsed, let's get the real @@ -6083,9 +6080,9 @@ find_what_var_points_to (varinfo_t orig_vi) vi = get_varinfo (find (orig_vi->id)); /* See if we have already computed the solution and return it. */ - slot = pointer_map_insert (final_solutions, vi); + pt_solution **slot = &final_solutions->get_or_insert (vi); if (*slot != NULL) - return *(struct pt_solution *)*slot; + return **slot; *slot = pt = XOBNEW (&final_solutions_obstack, struct pt_solution); memset (pt, 0, sizeof (struct pt_solution)); @@ -6685,8 +6682,8 @@ init_alias_vars (void) sizeof (struct variable_info), 30); constraints.create (8); varmap.create (8); - vi_for_tree = pointer_map_create (); - call_stmt_vars = pointer_map_create (); + vi_for_tree = new hash_map; + call_stmt_vars = new hash_map; memset (&stats, 0, sizeof (stats)); shared_bitmap_table = new hash_table (511); @@ -6694,7 +6691,7 @@ init_alias_vars (void) gcc_obstack_init (&fake_var_decl_obstack); - final_solutions = pointer_map_create (); + final_solutions = new hash_map; gcc_obstack_init (&final_solutions_obstack); } @@ -6943,8 +6940,8 @@ delete_points_to_sets (void) fprintf (dump_file, "Points to sets created:%d\n", stats.points_to_sets_created); - pointer_map_destroy (vi_for_tree); - pointer_map_destroy (call_stmt_vars); + delete vi_for_tree; + delete call_stmt_vars; bitmap_obstack_release (&pta_obstack); constraints.release (); @@ -6965,7 +6962,7 @@ delete_points_to_sets (void) obstack_free (&fake_var_decl_obstack, NULL); - pointer_map_destroy (final_solutions); + delete final_solutions; obstack_free (&final_solutions_obstack, NULL); } diff --git a/main/gcc/tree-ssa-tail-merge.c b/main/gcc/tree-ssa-tail-merge.c index 7245223ae8c..5615c791421 100644 --- a/main/gcc/tree-ssa-tail-merge.c +++ b/main/gcc/tree-ssa-tail-merge.c @@ -192,6 +192,7 @@ along with GCC; see the file COPYING3. If not see #include "tree.h" #include "stor-layout.h" #include "trans-mem.h" +#include "inchash.h" #include "tm_p.h" #include "basic-block.h" #include "flags.h" @@ -450,7 +451,7 @@ stmt_update_dep_bb (gimple stmt) static hashval_t same_succ_hash (const_same_succ e) { - hashval_t hashval = bitmap_hash (e->succs); + inchash::hash hstate (bitmap_hash (e->succs)); int flags; unsigned int i; unsigned int first = bitmap_first_set_bit (e->bbs); @@ -471,37 +472,35 @@ same_succ_hash (const_same_succ e) continue; size++; - hashval = iterative_hash_hashval_t (gimple_code (stmt), hashval); + hstate.add_int (gimple_code (stmt)); if (is_gimple_assign (stmt)) - hashval = iterative_hash_hashval_t (gimple_assign_rhs_code (stmt), - hashval); + hstate.add_int (gimple_assign_rhs_code (stmt)); if (!is_gimple_call (stmt)) continue; if (gimple_call_internal_p (stmt)) - hashval = iterative_hash_hashval_t - ((hashval_t) gimple_call_internal_fn (stmt), hashval); + hstate.add_int (gimple_call_internal_fn (stmt)); else { - hashval = iterative_hash_expr (gimple_call_fn (stmt), hashval); + inchash::add_expr (gimple_call_fn (stmt), hstate); if (gimple_call_chain (stmt)) - hashval = iterative_hash_expr (gimple_call_chain (stmt), hashval); + inchash::add_expr (gimple_call_chain (stmt), hstate); } for (i = 0; i < gimple_call_num_args (stmt); i++) { arg = gimple_call_arg (stmt, i); arg = vn_valueize (arg); - hashval = iterative_hash_expr (arg, hashval); + inchash::add_expr (arg, hstate); } } - hashval = iterative_hash_hashval_t (size, hashval); + hstate.add_int (size); BB_SIZE (bb) = size; for (i = 0; i < e->succ_flags.length (); ++i) { flags = e->succ_flags[i]; flags = flags & ~(EDGE_TRUE_VALUE | EDGE_FALSE_VALUE); - hashval = iterative_hash_hashval_t (flags, hashval); + hstate.add_int (flags); } EXECUTE_IF_SET_IN_BITMAP (e->succs, 0, s, bs) @@ -520,7 +519,7 @@ same_succ_hash (const_same_succ e) } } - return hashval; + return hstate.end (); } /* Returns true if E1 and E2 have 2 successors, and if the successor flags @@ -1160,17 +1159,9 @@ gimple_equal_p (same_succ same_succ, gimple s1, gimple s2) lhs2 = gimple_get_lhs (s2); if (TREE_CODE (lhs1) != SSA_NAME && TREE_CODE (lhs2) != SSA_NAME) - { - /* If the vdef is the same, it's the same statement. */ - if (vn_valueize (gimple_vdef (s1)) - == vn_valueize (gimple_vdef (s2))) - return true; - - /* Test for structural equality. */ - return (operand_equal_p (lhs1, lhs2, 0) - && gimple_operand_equal_value_p (gimple_assign_rhs1 (s1), - gimple_assign_rhs1 (s2))); - } + return (operand_equal_p (lhs1, lhs2, 0) + && gimple_operand_equal_value_p (gimple_assign_rhs1 (s1), + gimple_assign_rhs1 (s2))); else if (TREE_CODE (lhs1) == SSA_NAME && TREE_CODE (lhs2) == SSA_NAME) return vn_valueize (lhs1) == vn_valueize (lhs2); diff --git a/main/gcc/tree-ssa-threadedge.c b/main/gcc/tree-ssa-threadedge.c index 9807b421c74..3dee5badf4f 100644 --- a/main/gcc/tree-ssa-threadedge.c +++ b/main/gcc/tree-ssa-threadedge.c @@ -30,7 +30,7 @@ along with GCC; see the file COPYING3. If not see #include "function.h" #include "timevar.h" #include "dumpfile.h" -#include "pointer-set.h" +#include "hash-set.h" #include "tree-ssa-alias.h" #include "internal-fn.h" #include "gimple-expr.h" @@ -693,13 +693,13 @@ propagate_threaded_block_debug_into (basic_block dest, basic_block src) } auto_vec fewvars; - pointer_set_t *vars = NULL; + hash_set *vars = NULL; /* If we're already starting with 3/4 of alloc_count, go for a - pointer_set, otherwise start with an unordered stack-allocated + hash_set, otherwise start with an unordered stack-allocated VEC. */ if (i * 4 > alloc_count * 3) - vars = pointer_set_create (); + vars = new hash_set; /* Now go through the initial debug stmts in DEST again, this time actually inserting in VARS or FEWVARS. Don't bother checking for @@ -720,7 +720,7 @@ propagate_threaded_block_debug_into (basic_block dest, basic_block src) gcc_unreachable (); if (vars) - pointer_set_insert (vars, var); + vars->add (var); else fewvars.quick_push (var); } @@ -754,7 +754,7 @@ propagate_threaded_block_debug_into (basic_block dest, basic_block src) or somesuch. Adding `&& bb == src' to the condition below will preserve all potentially relevant debug notes. */ - if (vars && pointer_set_insert (vars, var)) + if (vars && vars->add (var)) continue; else if (!vars) { @@ -769,11 +769,11 @@ propagate_threaded_block_debug_into (basic_block dest, basic_block src) fewvars.quick_push (var); else { - vars = pointer_set_create (); + vars = new hash_set; for (i = 0; i < alloc_count; i++) - pointer_set_insert (vars, fewvars[i]); + vars->add (fewvars[i]); fewvars.release (); - pointer_set_insert (vars, var); + vars->add (var); } } @@ -786,7 +786,7 @@ propagate_threaded_block_debug_into (basic_block dest, basic_block src) while (bb != src && single_pred_p (bb)); if (vars) - pointer_set_destroy (vars); + delete vars; else if (fewvars.exists ()) fewvars.release (); } diff --git a/main/gcc/tree-ssa-uninit.c b/main/gcc/tree-ssa-uninit.c index 64259fbcc5f..f2578b7e8f8 100644 --- a/main/gcc/tree-ssa-uninit.c +++ b/main/gcc/tree-ssa-uninit.c @@ -29,6 +29,7 @@ along with GCC; see the file COPYING3. If not see #include "function.h" #include "gimple-pretty-print.h" #include "bitmap.h" +#include "hash-set.h" #include "pointer-set.h" #include "tree-ssa-alias.h" #include "internal-fn.h" @@ -60,7 +61,7 @@ along with GCC; see the file COPYING3. If not see /* Pointer set of potentially undefined ssa names, i.e., ssa names that are defined by phi with operands that are not defined or potentially undefined. */ -static pointer_set_t *possibly_undefined_names = 0; +static hash_set *possibly_undefined_names = 0; /* Bit mask handling macros. */ #define MASK_SET_BIT(mask, pos) mask |= (1 << pos) @@ -89,7 +90,7 @@ has_undefined_value_p (tree t) { return (ssa_undefined_value_p (t) || (possibly_undefined_names - && pointer_set_contains (possibly_undefined_names, t))); + && possibly_undefined_names->contains (t))); } @@ -648,13 +649,13 @@ find_predicates (pred_chain_union *preds, static void collect_phi_def_edges (gimple phi, basic_block cd_root, vec *edges, - pointer_set_t *visited_phis) + hash_set *visited_phis) { size_t i, n; edge opnd_edge; tree opnd; - if (pointer_set_insert (visited_phis, phi)) + if (visited_phis->add (phi)) return; n = gimple_phi_num_args (phi); @@ -707,7 +708,6 @@ find_def_preds (pred_chain_union *preds, gimple phi) vec def_edges = vNULL; bool has_valid_pred = false; basic_block phi_bb, cd_root = 0; - pointer_set_t *visited_phis; phi_bb = gimple_bb (phi); /* First find the closest dominating bb to be @@ -716,9 +716,8 @@ find_def_preds (pred_chain_union *preds, gimple phi) if (!cd_root) return false; - visited_phis = pointer_set_create (); - collect_phi_def_edges (phi, cd_root, &def_edges, visited_phis); - pointer_set_destroy (visited_phis); + hash_set visited_phis; + collect_phi_def_edges (phi, cd_root, &def_edges, &visited_phis); n = def_edges.length (); if (n == 0) @@ -941,7 +940,7 @@ is_use_properly_guarded (gimple use_stmt, basic_block use_bb, gimple phi, unsigned uninit_opnds, - pointer_set_t *visited_phis); + hash_set *visited_phis); /* Returns true if all uninitialized opnds are pruned. Returns false otherwise. PHI is the phi node with uninitialized operands, @@ -983,7 +982,7 @@ prune_uninit_phi_opnds_in_unrealizable_paths (gimple phi, gimple flag_def, tree boundary_cst, enum tree_code cmp_code, - pointer_set_t *visited_phis, + hash_set *visited_phis, bitmap *visited_flag_phis) { unsigned i; @@ -1153,7 +1152,7 @@ prune_uninit_phi_opnds_in_unrealizable_paths (gimple phi, static bool use_pred_not_overlap_with_undef_path_pred (pred_chain_union preds, gimple phi, unsigned uninit_opnds, - pointer_set_t *visited_phis) + hash_set *visited_phis) { unsigned int i, n; gimple flag_def = 0; @@ -1818,11 +1817,11 @@ push_pred (pred_chain_union *norm_preds, pred_info pred) inline static void push_to_worklist (tree op, vec *work_list, - pointer_set_t *mark_set) + hash_set *mark_set) { - if (pointer_set_contains (mark_set, op)) + if (mark_set->contains (op)) return; - pointer_set_insert (mark_set, op); + mark_set->add (op); pred_info arg_pred; arg_pred.pred_lhs = op; @@ -1907,7 +1906,7 @@ normalize_one_pred_1 (pred_chain_union *norm_preds, pred_info pred, enum tree_code and_or_code, vec *work_list, - pointer_set_t *mark_set) + hash_set *mark_set) { if (!is_neq_zero_form_p (pred)) { @@ -1987,7 +1986,6 @@ normalize_one_pred (pred_chain_union *norm_preds, pred_info pred) { vec work_list = vNULL; - pointer_set_t *mark_set = NULL; enum tree_code and_or_code = ERROR_MARK; pred_chain norm_chain = vNULL; @@ -2015,19 +2013,18 @@ normalize_one_pred (pred_chain_union *norm_preds, } work_list.safe_push (pred); - mark_set = pointer_set_create (); + hash_set mark_set; while (!work_list.is_empty ()) { pred_info a_pred = work_list.pop (); normalize_one_pred_1 (norm_preds, &norm_chain, a_pred, - and_or_code, &work_list, mark_set); + and_or_code, &work_list, &mark_set); } if (and_or_code == BIT_AND_EXPR) norm_preds->safe_push (norm_chain); work_list.release (); - pointer_set_destroy (mark_set); } static void @@ -2035,26 +2032,25 @@ normalize_one_pred_chain (pred_chain_union *norm_preds, pred_chain one_chain) { vec work_list = vNULL; - pointer_set_t *mark_set = pointer_set_create (); + hash_set mark_set; pred_chain norm_chain = vNULL; size_t i; for (i = 0; i < one_chain.length (); i++) { work_list.safe_push (one_chain[i]); - pointer_set_insert (mark_set, one_chain[i].pred_lhs); + mark_set.add (one_chain[i].pred_lhs); } while (!work_list.is_empty ()) { pred_info a_pred = work_list.pop (); normalize_one_pred_1 (0, &norm_chain, a_pred, - BIT_AND_EXPR, &work_list, mark_set); + BIT_AND_EXPR, &work_list, &mark_set); } norm_preds->safe_push (norm_chain); work_list.release (); - pointer_set_destroy (mark_set); } /* Normalize predicate chains PREDS and returns the normalized one. */ @@ -2112,7 +2108,7 @@ is_use_properly_guarded (gimple use_stmt, basic_block use_bb, gimple phi, unsigned uninit_opnds, - pointer_set_t *visited_phis) + hash_set *visited_phis) { basic_block phi_bb; pred_chain_union preds = vNULL; @@ -2120,7 +2116,7 @@ is_use_properly_guarded (gimple use_stmt, bool has_valid_preds = false; bool is_properly_guarded = false; - if (pointer_set_insert (visited_phis, phi)) + if (visited_phis->add (phi)) return false; phi_bb = gimple_bb (phi); @@ -2181,7 +2177,7 @@ is_use_properly_guarded (gimple use_stmt, static gimple find_uninit_use (gimple phi, unsigned uninit_opnds, vec *worklist, - pointer_set_t *added_to_worklist) + hash_set *added_to_worklist) { tree phi_result; use_operand_p use_p; @@ -2192,28 +2188,22 @@ find_uninit_use (gimple phi, unsigned uninit_opnds, FOR_EACH_IMM_USE_FAST (use_p, iter, phi_result) { - pointer_set_t *visited_phis; basic_block use_bb; use_stmt = USE_STMT (use_p); if (is_gimple_debug (use_stmt)) continue; - visited_phis = pointer_set_create (); - if (gimple_code (use_stmt) == GIMPLE_PHI) use_bb = gimple_phi_arg_edge (use_stmt, PHI_ARG_INDEX_FROM_USE (use_p))->src; else use_bb = gimple_bb (use_stmt); + hash_set visited_phis; if (is_use_properly_guarded (use_stmt, use_bb, phi, uninit_opnds, - visited_phis)) - { - pointer_set_destroy (visited_phis); - continue; - } - pointer_set_destroy (visited_phis); + &visited_phis)) + continue; if (dump_file && (dump_flags & TDF_DETAILS)) { @@ -2226,7 +2216,7 @@ find_uninit_use (gimple phi, unsigned uninit_opnds, /* Found a phi use that is not guarded, add the phi to the worklist. */ - if (!pointer_set_insert (added_to_worklist, use_stmt)) + if (!added_to_worklist->add (use_stmt)) { if (dump_file && (dump_flags & TDF_DETAILS)) { @@ -2235,7 +2225,7 @@ find_uninit_use (gimple phi, unsigned uninit_opnds, } worklist->safe_push (use_stmt); - pointer_set_insert (possibly_undefined_names, phi_result); + possibly_undefined_names->add (phi_result); } } @@ -2252,7 +2242,7 @@ find_uninit_use (gimple phi, unsigned uninit_opnds, static void warn_uninitialized_phi (gimple phi, vec *worklist, - pointer_set_t *added_to_worklist) + hash_set *added_to_worklist) { unsigned uninit_opnds; gimple uninit_use_stmt = 0; @@ -2339,7 +2329,6 @@ pass_late_warn_uninitialized::execute (function *fun) basic_block bb; gimple_stmt_iterator gsi; vec worklist = vNULL; - pointer_set_t *added_to_worklist; calculate_dominance_info (CDI_DOMINATORS); calculate_dominance_info (CDI_POST_DOMINATORS); @@ -2350,8 +2339,8 @@ pass_late_warn_uninitialized::execute (function *fun) timevar_push (TV_TREE_UNINIT); - possibly_undefined_names = pointer_set_create (); - added_to_worklist = pointer_set_create (); + possibly_undefined_names = new hash_set; + hash_set added_to_worklist; /* Initialize worklist */ FOR_EACH_BB_FN (bb, fun) @@ -2373,7 +2362,7 @@ pass_late_warn_uninitialized::execute (function *fun) && uninit_undefined_value_p (op)) { worklist.safe_push (phi); - pointer_set_insert (added_to_worklist, phi); + added_to_worklist.add (phi); if (dump_file && (dump_flags & TDF_DETAILS)) { fprintf (dump_file, "[WORKLIST]: add to initial list: "); @@ -2388,12 +2377,11 @@ pass_late_warn_uninitialized::execute (function *fun) { gimple cur_phi = 0; cur_phi = worklist.pop (); - warn_uninitialized_phi (cur_phi, &worklist, added_to_worklist); + warn_uninitialized_phi (cur_phi, &worklist, &added_to_worklist); } worklist.release (); - pointer_set_destroy (added_to_worklist); - pointer_set_destroy (possibly_undefined_names); + delete possibly_undefined_names; possibly_undefined_names = NULL; free_dominance_info (CDI_POST_DOMINATORS); timevar_pop (TV_TREE_UNINIT); diff --git a/main/gcc/tree-ssa.c b/main/gcc/tree-ssa.c index 87b25bd0c8c..971ce32bf0b 100644 --- a/main/gcc/tree-ssa.c +++ b/main/gcc/tree-ssa.c @@ -49,6 +49,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-into-ssa.h" #include "tree-ssa.h" #include "tree-inline.h" +#include "hash-map.h" #include "hashtab.h" #include "tree-pass.h" #include "diagnostic-core.h" @@ -57,7 +58,7 @@ along with GCC; see the file COPYING3. If not see #include "cfgexpand.h" /* Pointer map of variable mappings, keyed by edge. */ -static struct pointer_map_t *edge_var_maps; +static hash_map > *edge_var_maps; /* Add a mapping with PHI RESULT and PHI DEF associated with edge E. */ @@ -65,23 +66,17 @@ static struct pointer_map_t *edge_var_maps; void redirect_edge_var_map_add (edge e, tree result, tree def, source_location locus) { - void **slot; - edge_var_map_vector *head; edge_var_map new_node; if (edge_var_maps == NULL) - edge_var_maps = pointer_map_create (); + edge_var_maps = new hash_map >; - slot = pointer_map_insert (edge_var_maps, e); - head = (edge_var_map_vector *) *slot; - if (!head) - vec_safe_reserve (head, 5); + auto_vec &slot = edge_var_maps->get_or_insert (e); new_node.def = def; new_node.result = result; new_node.locus = locus; - vec_safe_push (head, new_node); - *slot = head; + slot.safe_push (new_node); } @@ -90,82 +85,51 @@ redirect_edge_var_map_add (edge e, tree result, tree def, source_location locus) void redirect_edge_var_map_clear (edge e) { - void **slot; - edge_var_map_vector *head; - if (!edge_var_maps) return; - slot = pointer_map_contains (edge_var_maps, e); + auto_vec *head = edge_var_maps->get (e); - if (slot) - { - head = (edge_var_map_vector *) *slot; - vec_free (head); - *slot = NULL; - } + if (head) + head->release (); } /* Duplicate the redirected var mappings in OLDE in NEWE. - Since we can't remove a mapping, let's just duplicate it. This assumes a - pointer_map can have multiple edges mapping to the same var_map (many to - one mapping), since we don't remove the previous mappings. */ + This assumes a hash_map can have multiple edges mapping to the same + var_map (many to one mapping), since we don't remove the previous mappings. + */ void redirect_edge_var_map_dup (edge newe, edge olde) { - void **new_slot, **old_slot; - edge_var_map_vector *head; - if (!edge_var_maps) return; - new_slot = pointer_map_insert (edge_var_maps, newe); - old_slot = pointer_map_contains (edge_var_maps, olde); - if (!old_slot) + auto_vec *head = edge_var_maps->get (olde); + if (!head) return; - head = (edge_var_map_vector *) *old_slot; - edge_var_map_vector *new_head = NULL; - if (head) - new_head = vec_safe_copy (head); - else - vec_safe_reserve (new_head, 5); - *new_slot = new_head; + edge_var_maps->get_or_insert (newe).safe_splice (*head); } /* Return the variable mappings for a given edge. If there is none, return NULL. */ -edge_var_map_vector * +vec * redirect_edge_var_map_vector (edge e) { - void **slot; - /* Hey, what kind of idiot would... you'd be surprised. */ if (!edge_var_maps) return NULL; - slot = pointer_map_contains (edge_var_maps, e); + auto_vec *slot = edge_var_maps->get (e); if (!slot) return NULL; - return (edge_var_map_vector *) *slot; -} - -/* Used by redirect_edge_var_map_destroy to free all memory. */ - -static bool -free_var_map_entry (const void *key ATTRIBUTE_UNUSED, - void **value, - void *data ATTRIBUTE_UNUSED) -{ - edge_var_map_vector *head = (edge_var_map_vector *) *value; - vec_free (head); - return true; + return slot; } /* Clear the edge variable mappings. */ @@ -173,12 +137,8 @@ free_var_map_entry (const void *key ATTRIBUTE_UNUSED, void redirect_edge_var_map_destroy (void) { - if (edge_var_maps) - { - pointer_map_traverse (edge_var_maps, free_var_map_entry, NULL); - pointer_map_destroy (edge_var_maps); - edge_var_maps = NULL; - } + delete edge_var_maps; + edge_var_maps = NULL; } @@ -224,12 +184,11 @@ void flush_pending_stmts (edge e) { gimple phi; - edge_var_map_vector *v; edge_var_map *vm; int i; gimple_stmt_iterator gsi; - v = redirect_edge_var_map_vector (e); + vec *v = redirect_edge_var_map_vector (e); if (!v) return; diff --git a/main/gcc/tree-ssa.h b/main/gcc/tree-ssa.h index c866206d522..835686c664c 100644 --- a/main/gcc/tree-ssa.h +++ b/main/gcc/tree-ssa.h @@ -35,7 +35,7 @@ typedef vec edge_var_map_vector; extern void redirect_edge_var_map_add (edge, tree, tree, source_location); extern void redirect_edge_var_map_clear (edge); extern void redirect_edge_var_map_dup (edge, edge); -extern edge_var_map_vector *redirect_edge_var_map_vector (edge); +extern vec *redirect_edge_var_map_vector (edge); extern void redirect_edge_var_map_destroy (void); extern edge ssa_redirect_edge (edge, basic_block); extern void flush_pending_stmts (edge); diff --git a/main/gcc/tree.c b/main/gcc/tree.c index 6ad5f58c6eb..32b6004f4ff 100644 --- a/main/gcc/tree.c +++ b/main/gcc/tree.c @@ -42,6 +42,7 @@ along with GCC; see the file COPYING3. If not see #include "obstack.h" #include "toplev.h" /* get_random_seed */ #include "hashtab.h" +#include "inchash.h" #include "filenames.h" #include "output.h" #include "target.h" @@ -231,8 +232,8 @@ static void print_type_hash_statistics (void); static void print_debug_expr_statistics (void); static void print_value_expr_statistics (void); static int type_hash_marked_p (const void *); -static unsigned int type_hash_list (const_tree, hashval_t); -static unsigned int attribute_hash_list (const_tree, hashval_t); +static void type_hash_list (const_tree, inchash::hash &); +static void attribute_hash_list (const_tree, inchash::hash &); tree global_trees[TI_MAX]; tree integer_types[itk_none]; @@ -4583,56 +4584,6 @@ build_decl_attribute_variant (tree ddecl, tree attribute) return ddecl; } -/* Borrowed from hashtab.c iterative_hash implementation. */ -#define mix(a,b,c) \ -{ \ - a -= b; a -= c; a ^= (c>>13); \ - b -= c; b -= a; b ^= (a<< 8); \ - c -= a; c -= b; c ^= ((b&0xffffffff)>>13); \ - a -= b; a -= c; a ^= ((c&0xffffffff)>>12); \ - b -= c; b -= a; b = (b ^ (a<<16)) & 0xffffffff; \ - c -= a; c -= b; c = (c ^ (b>> 5)) & 0xffffffff; \ - a -= b; a -= c; a = (a ^ (c>> 3)) & 0xffffffff; \ - b -= c; b -= a; b = (b ^ (a<<10)) & 0xffffffff; \ - c -= a; c -= b; c = (c ^ (b>>15)) & 0xffffffff; \ -} - - -/* Produce good hash value combining VAL and VAL2. */ -hashval_t -iterative_hash_hashval_t (hashval_t val, hashval_t val2) -{ - /* the golden ratio; an arbitrary value. */ - hashval_t a = 0x9e3779b9; - - mix (a, val, val2); - return val2; -} - -/* Produce good hash value combining VAL and VAL2. */ -hashval_t -iterative_hash_host_wide_int (HOST_WIDE_INT val, hashval_t val2) -{ - if (sizeof (HOST_WIDE_INT) == sizeof (hashval_t)) - return iterative_hash_hashval_t (val, val2); - else - { - hashval_t a = (hashval_t) val; - /* Avoid warnings about shifting of more than the width of the type on - hosts that won't execute this path. */ - int zero = 0; - hashval_t b = (hashval_t) (val >> (sizeof (hashval_t) * 8 + zero)); - mix (a, b, val2); - if (sizeof (HOST_WIDE_INT) > 2 * sizeof (hashval_t)) - { - hashval_t a = (hashval_t) (val >> (sizeof (hashval_t) * 16 + zero)); - hashval_t b = (hashval_t) (val >> (sizeof (hashval_t) * 24 + zero)); - mix (a, b, val2); - } - return val2; - } -} - /* Return a type like TTYPE except that its TYPE_ATTRIBUTE is ATTRIBUTE and its qualifiers are QUALS. @@ -4643,7 +4594,7 @@ build_type_attribute_qual_variant (tree ttype, tree attribute, int quals) { if (! attribute_list_equal (TYPE_ATTRIBUTES (ttype), attribute)) { - hashval_t hashcode = 0; + inchash::hash hstate; tree ntype; int i; tree t; @@ -4671,39 +4622,37 @@ build_type_attribute_qual_variant (tree ttype, tree attribute, int quals) TYPE_ATTRIBUTES (ntype) = attribute; - hashcode = iterative_hash_object (code, hashcode); + hstate.add_int (code); if (TREE_TYPE (ntype)) - hashcode = iterative_hash_object (TYPE_HASH (TREE_TYPE (ntype)), - hashcode); - hashcode = attribute_hash_list (attribute, hashcode); + hstate.add_object (TYPE_HASH (TREE_TYPE (ntype))); + attribute_hash_list (attribute, hstate); switch (TREE_CODE (ntype)) { case FUNCTION_TYPE: - hashcode = type_hash_list (TYPE_ARG_TYPES (ntype), hashcode); + type_hash_list (TYPE_ARG_TYPES (ntype), hstate); break; case ARRAY_TYPE: if (TYPE_DOMAIN (ntype)) - hashcode = iterative_hash_object (TYPE_HASH (TYPE_DOMAIN (ntype)), - hashcode); + hstate.add_object (TYPE_HASH (TYPE_DOMAIN (ntype))); break; case INTEGER_TYPE: t = TYPE_MAX_VALUE (ntype); for (i = 0; i < TREE_INT_CST_NUNITS (t); i++) - hashcode = iterative_hash_object (TREE_INT_CST_ELT (t, i), hashcode); + hstate.add_object (TREE_INT_CST_ELT (t, i)); break; case REAL_TYPE: case FIXED_POINT_TYPE: { unsigned int precision = TYPE_PRECISION (ntype); - hashcode = iterative_hash_object (precision, hashcode); + hstate.add_object (precision); } break; default: break; } - ntype = type_hash_canon (hashcode, ntype); + ntype = type_hash_canon (hstate.end(), ntype); /* If the target-dependent attributes make NTYPE different from its canonical type, we will need to use structural equality @@ -5195,7 +5144,7 @@ struct free_lang_data_d vec worklist; /* Set of traversed objects. Used to avoid duplicate visits. */ - struct pointer_set_t *pset; + hash_set *pset; /* Array of symbols to process with free_lang_data_in_decl. */ vec decls; @@ -5260,7 +5209,7 @@ add_tree_to_fld_list (tree t, struct free_lang_data_d *fld) static inline void fld_worklist_push (tree t, struct free_lang_data_d *fld) { - if (t && !is_lang_specific (t) && !pointer_set_contains (fld->pset, t)) + if (t && !is_lang_specific (t) && !fld->pset->contains (t)) fld->worklist.safe_push ((t)); } @@ -5426,7 +5375,7 @@ find_decls_types (tree t, struct free_lang_data_d *fld) { while (1) { - if (!pointer_set_contains (fld->pset, t)) + if (!fld->pset->contains (t)) walk_tree (&t, find_decls_types_r, fld, fld->pset); if (fld->worklist.is_empty ()) break; @@ -5636,7 +5585,7 @@ free_lang_data_in_cgraph (void) alias_pair *p; /* Initialize sets and arrays to store referenced decls and types. */ - fld.pset = pointer_set_create (); + fld.pset = new hash_set; fld.worklist.create (0); fld.decls.create (100); fld.types.create (100); @@ -5666,7 +5615,7 @@ free_lang_data_in_cgraph (void) FOR_EACH_VEC_ELT (fld.types, i, t) free_lang_data_in_type (t); - pointer_set_destroy (fld.pset); + delete fld.pset; fld.worklist.release (); fld.decls.release (); fld.types.release (); @@ -6682,17 +6631,14 @@ decl_debug_args_insert (tree from) with types in the TREE_VALUE slots), by adding the hash codes of the individual types. */ -static unsigned int -type_hash_list (const_tree list, hashval_t hashcode) +static void +type_hash_list (const_tree list, inchash::hash &hstate) { const_tree tail; for (tail = list; tail; tail = TREE_CHAIN (tail)) if (TREE_VALUE (tail) != error_mark_node) - hashcode = iterative_hash_object (TYPE_HASH (TREE_VALUE (tail)), - hashcode); - - return hashcode; + hstate.add_object (TYPE_HASH (TREE_VALUE (tail))); } /* These are the Hashtable callback functions. */ @@ -6920,16 +6866,14 @@ print_type_hash_statistics (void) with names in the TREE_PURPOSE slots and args in the TREE_VALUE slots), by adding the hash codes of the individual attributes. */ -static unsigned int -attribute_hash_list (const_tree list, hashval_t hashcode) +static void +attribute_hash_list (const_tree list, inchash::hash &hstate) { const_tree tail; for (tail = list; tail; tail = TREE_CHAIN (tail)) /* ??? Do we want to add in TREE_VALUE too? */ - hashcode = iterative_hash_object - (IDENTIFIER_HASH_VALUE (get_attribute_name (tail)), hashcode); - return hashcode; + hstate.add_object (IDENTIFIER_HASH_VALUE (get_attribute_name (tail))); } /* Given two lists of attributes, return true if list l2 is @@ -7441,21 +7385,26 @@ commutative_ternary_tree_code (enum tree_code code) return false; } +namespace inchash +{ + /* Generate a hash value for an expression. This can be used iteratively - by passing a previous result as the VAL argument. + by passing a previous result as the HSTATE argument. This function is intended to produce the same hash for expressions which would compare equal using operand_equal_p. */ - -hashval_t -iterative_hash_expr (const_tree t, hashval_t val) +void +add_expr (const_tree t, inchash::hash &hstate) { int i; enum tree_code code; enum tree_code_class tclass; if (t == NULL_TREE) - return iterative_hash_hashval_t (0, val); + { + hstate.merge_hash (0); + return; + } code = TREE_CODE (t); @@ -7464,58 +7413,61 @@ iterative_hash_expr (const_tree t, hashval_t val) /* Alas, constants aren't shared, so we can't rely on pointer identity. */ case VOID_CST: - return iterative_hash_hashval_t (0, val); + hstate.merge_hash (0); + return; case INTEGER_CST: for (i = 0; i < TREE_INT_CST_NUNITS (t); i++) - val = iterative_hash_host_wide_int (TREE_INT_CST_ELT (t, i), val); - return val; + hstate.add_wide_int (TREE_INT_CST_ELT (t, i)); + return; case REAL_CST: { unsigned int val2 = real_hash (TREE_REAL_CST_PTR (t)); - - return iterative_hash_hashval_t (val2, val); + hstate.merge_hash (val2); + return; } case FIXED_CST: { unsigned int val2 = fixed_hash (TREE_FIXED_CST_PTR (t)); - - return iterative_hash_hashval_t (val2, val); + hstate.merge_hash (val2); + return; } case STRING_CST: - return iterative_hash (TREE_STRING_POINTER (t), - TREE_STRING_LENGTH (t), val); + hstate.add ((const void *) TREE_STRING_POINTER (t), TREE_STRING_LENGTH (t)); + return; case COMPLEX_CST: - val = iterative_hash_expr (TREE_REALPART (t), val); - return iterative_hash_expr (TREE_IMAGPART (t), val); + inchash::add_expr (TREE_REALPART (t), hstate); + inchash::add_expr (TREE_IMAGPART (t), hstate); + return; case VECTOR_CST: { unsigned i; for (i = 0; i < VECTOR_CST_NELTS (t); ++i) - val = iterative_hash_expr (VECTOR_CST_ELT (t, i), val); - return val; + inchash::add_expr (VECTOR_CST_ELT (t, i), hstate); + return; } case SSA_NAME: /* We can just compare by pointer. */ - return iterative_hash_host_wide_int (SSA_NAME_VERSION (t), val); + hstate.add_wide_int (SSA_NAME_VERSION (t)); + return; case PLACEHOLDER_EXPR: /* The node itself doesn't matter. */ - return val; + return; case TREE_LIST: /* A list of expressions, for a CALL_EXPR or as the elements of a VECTOR_CST. */ for (; t; t = TREE_CHAIN (t)) - val = iterative_hash_expr (TREE_VALUE (t), val); - return val; + inchash::add_expr (TREE_VALUE (t), hstate); + return; case CONSTRUCTOR: { unsigned HOST_WIDE_INT idx; tree field, value; FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (t), idx, field, value) { - val = iterative_hash_expr (field, val); - val = iterative_hash_expr (value, val); + inchash::add_expr (field, hstate); + inchash::add_expr (value, hstate); } - return val; + return; } case FUNCTION_DECL: /* When referring to a built-in FUNCTION_DECL, use the __builtin__ form. @@ -7536,13 +7488,13 @@ iterative_hash_expr (const_tree t, hashval_t val) if (tclass == tcc_declaration) { /* DECL's have a unique ID */ - val = iterative_hash_host_wide_int (DECL_UID (t), val); + hstate.add_wide_int (DECL_UID (t)); } else { gcc_assert (IS_EXPR_CODE_CLASS (tclass)); - val = iterative_hash_object (code, val); + hstate.add_object (code); /* Don't hash the type, that can lead to having nodes which compare equal according to operand_equal_p, but which @@ -7551,8 +7503,8 @@ iterative_hash_expr (const_tree t, hashval_t val) || code == NON_LVALUE_EXPR) { /* Make sure to include signness in the hash computation. */ - val += TYPE_UNSIGNED (TREE_TYPE (t)); - val = iterative_hash_expr (TREE_OPERAND (t, 0), val); + hstate.add_int (TYPE_UNSIGNED (TREE_TYPE (t))); + inchash::add_expr (TREE_OPERAND (t, 0), hstate); } else if (commutative_tree_code (code)) @@ -7561,24 +7513,21 @@ iterative_hash_expr (const_tree t, hashval_t val) however it appears. We do this by first hashing both operands and then rehashing based on the order of their independent hashes. */ - hashval_t one = iterative_hash_expr (TREE_OPERAND (t, 0), 0); - hashval_t two = iterative_hash_expr (TREE_OPERAND (t, 1), 0); - hashval_t t; - - if (one > two) - t = one, one = two, two = t; - - val = iterative_hash_hashval_t (one, val); - val = iterative_hash_hashval_t (two, val); + inchash::hash one, two; + inchash::add_expr (TREE_OPERAND (t, 0), one); + inchash::add_expr (TREE_OPERAND (t, 1), two); + hstate.add_commutative (one, two); } else for (i = TREE_OPERAND_LENGTH (t) - 1; i >= 0; --i) - val = iterative_hash_expr (TREE_OPERAND (t, i), val); + inchash::add_expr (TREE_OPERAND (t, i), hstate); } - return val; + return; } } +} + /* Constructors for pointer, array and function types. (RECORD_TYPE, UNION_TYPE and ENUMERAL_TYPE nodes are constructed by language-dependent code, not here.) */ @@ -7768,7 +7717,7 @@ static tree build_range_type_1 (tree type, tree lowval, tree highval, bool shared) { tree itype = make_node (INTEGER_TYPE); - hashval_t hashcode = 0; + inchash::hash hstate; TREE_TYPE (itype) = type; @@ -7796,10 +7745,10 @@ build_range_type_1 (tree type, tree lowval, tree highval, bool shared) return itype; } - hashcode = iterative_hash_expr (TYPE_MIN_VALUE (itype), hashcode); - hashcode = iterative_hash_expr (TYPE_MAX_VALUE (itype), hashcode); - hashcode = iterative_hash_hashval_t (TYPE_HASH (type), hashcode); - itype = type_hash_canon (hashcode, itype); + inchash::add_expr (TYPE_MIN_VALUE (itype), hstate); + inchash::add_expr (TYPE_MAX_VALUE (itype), hstate); + hstate.merge_hash (TYPE_HASH (type)); + itype = type_hash_canon (hstate.end (), itype); return itype; } @@ -7904,10 +7853,11 @@ build_array_type_1 (tree elt_type, tree index_type, bool shared) if (shared) { - hashval_t hashcode = iterative_hash_object (TYPE_HASH (elt_type), 0); + inchash::hash hstate; + hstate.add_object (TYPE_HASH (elt_type)); if (index_type) - hashcode = iterative_hash_object (TYPE_HASH (index_type), hashcode); - t = type_hash_canon (hashcode, t); + hstate.add_object (TYPE_HASH (index_type)); + t = type_hash_canon (hstate.end (), t); } if (TYPE_CANONICAL (t) == t) @@ -8047,7 +7997,7 @@ tree build_function_type (tree value_type, tree arg_types) { tree t; - hashval_t hashcode = 0; + inchash::hash hstate; bool any_structural_p, any_noncanonical_p; tree canon_argtypes; @@ -8063,9 +8013,9 @@ build_function_type (tree value_type, tree arg_types) TYPE_ARG_TYPES (t) = arg_types; /* If we already have such a type, use the old one. */ - hashcode = iterative_hash_object (TYPE_HASH (value_type), hashcode); - hashcode = type_hash_list (arg_types, hashcode); - t = type_hash_canon (hashcode, t); + hstate.add_object (TYPE_HASH (value_type)); + type_hash_list (arg_types, hstate); + t = type_hash_canon (hstate.end (), t); /* Set up the canonical type. */ any_structural_p = TYPE_STRUCTURAL_EQUALITY_P (value_type); @@ -8202,7 +8152,7 @@ build_method_type_directly (tree basetype, { tree t; tree ptype; - int hashcode = 0; + inchash::hash hstate; bool any_structural_p, any_noncanonical_p; tree canon_argtypes; @@ -8219,10 +8169,10 @@ build_method_type_directly (tree basetype, TYPE_ARG_TYPES (t) = argtypes; /* If we already have such a type, use the old one. */ - hashcode = iterative_hash_object (TYPE_HASH (basetype), hashcode); - hashcode = iterative_hash_object (TYPE_HASH (rettype), hashcode); - hashcode = type_hash_list (argtypes, hashcode); - t = type_hash_canon (hashcode, t); + hstate.add_object (TYPE_HASH (basetype)); + hstate.add_object (TYPE_HASH (rettype)); + type_hash_list (argtypes, hstate); + t = type_hash_canon (hstate.end (), t); /* Set up the canonical type. */ any_structural_p @@ -8270,7 +8220,7 @@ tree build_offset_type (tree basetype, tree type) { tree t; - hashval_t hashcode = 0; + inchash::hash hstate; /* Make a node of the sort we want. */ t = make_node (OFFSET_TYPE); @@ -8279,9 +8229,9 @@ build_offset_type (tree basetype, tree type) TREE_TYPE (t) = type; /* If we already have such a type, use the old one. */ - hashcode = iterative_hash_object (TYPE_HASH (basetype), hashcode); - hashcode = iterative_hash_object (TYPE_HASH (type), hashcode); - t = type_hash_canon (hashcode, t); + hstate.add_object (TYPE_HASH (basetype)); + hstate.add_object (TYPE_HASH (type)); + t = type_hash_canon (hstate.end (), t); if (!COMPLETE_TYPE_P (t)) layout_type (t); @@ -8307,7 +8257,7 @@ tree build_complex_type (tree component_type) { tree t; - hashval_t hashcode; + inchash::hash hstate; gcc_assert (INTEGRAL_TYPE_P (component_type) || SCALAR_FLOAT_TYPE_P (component_type) @@ -8319,8 +8269,8 @@ build_complex_type (tree component_type) TREE_TYPE (t) = TYPE_MAIN_VARIANT (component_type); /* If we already have such a type, use the old one. */ - hashcode = iterative_hash_object (TYPE_HASH (component_type), 0); - t = type_hash_canon (hashcode, t); + hstate.add_object (TYPE_HASH (component_type)); + t = type_hash_canon (hstate.end (), t); if (!COMPLETE_TYPE_P (t)) layout_type (t); @@ -9459,7 +9409,7 @@ static tree make_vector_type (tree innertype, int nunits, enum machine_mode mode) { tree t; - hashval_t hashcode = 0; + inchash::hash hstate; t = make_node (VECTOR_TYPE); TREE_TYPE (t) = TYPE_MAIN_VARIANT (innertype); @@ -9475,11 +9425,11 @@ make_vector_type (tree innertype, int nunits, enum machine_mode mode) layout_type (t); - hashcode = iterative_hash_host_wide_int (VECTOR_TYPE, hashcode); - hashcode = iterative_hash_host_wide_int (nunits, hashcode); - hashcode = iterative_hash_host_wide_int (mode, hashcode); - hashcode = iterative_hash_object (TYPE_HASH (TREE_TYPE (t)), hashcode); - t = type_hash_canon (hashcode, t); + hstate.add_wide_int (VECTOR_TYPE); + hstate.add_wide_int (nunits); + hstate.add_wide_int (mode); + hstate.add_object (TYPE_HASH (TREE_TYPE (t))); + t = type_hash_canon (hstate.end (), t); /* We have built a main variant, based on the main variant of the inner type. Use it to build the variant we return. */ @@ -10875,7 +10825,7 @@ num_ending_zeros (const_tree x) static tree walk_type_fields (tree type, walk_tree_fn func, void *data, - struct pointer_set_t *pset, walk_tree_lh lh) + hash_set *pset, walk_tree_lh lh) { tree result = NULL_TREE; @@ -10957,7 +10907,7 @@ walk_type_fields (tree type, walk_tree_fn func, void *data, tree walk_tree_1 (tree *tp, walk_tree_fn func, void *data, - struct pointer_set_t *pset, walk_tree_lh lh) + hash_set *pset, walk_tree_lh lh) { enum tree_code code; int walk_subtrees; @@ -10978,7 +10928,7 @@ walk_tree_1 (tree *tp, walk_tree_fn func, void *data, /* Don't walk the same tree twice, if the user has requested that we avoid doing so. */ - if (pset && pointer_set_insert (pset, *tp)) + if (pset && pset->add (*tp)) return NULL_TREE; /* Call the function. */ @@ -11293,11 +11243,9 @@ walk_tree_without_duplicates_1 (tree *tp, walk_tree_fn func, void *data, walk_tree_lh lh) { tree result; - struct pointer_set_t *pset; - pset = pointer_set_create (); - result = walk_tree_1 (tp, func, data, pset, lh); - pointer_set_destroy (pset); + hash_set pset; + result = walk_tree_1 (tp, func, data, &pset, lh); return result; } diff --git a/main/gcc/tree.h b/main/gcc/tree.h index cfe79a71236..51e60970213 100644 --- a/main/gcc/tree.h +++ b/main/gcc/tree.h @@ -21,7 +21,9 @@ along with GCC; see the file COPYING3. If not see #define GCC_TREE_H #include "tree-core.h" +#include "hash-set.h" #include "wide-int.h" +#include "inchash.h" /* These includes are required here because they provide declarations used by inline functions in this file. @@ -4287,10 +4289,23 @@ extern int tree_log2 (const_tree); extern int tree_floor_log2 (const_tree); extern unsigned int tree_ctz (const_tree); extern int simple_cst_equal (const_tree, const_tree); -extern hashval_t iterative_hash_expr (const_tree, hashval_t); -extern hashval_t iterative_hash_host_wide_int (HOST_WIDE_INT, hashval_t); -extern hashval_t iterative_hash_hashval_t (hashval_t, hashval_t); -extern hashval_t iterative_hash_host_wide_int (HOST_WIDE_INT, hashval_t); + +namespace inchash +{ + +extern void add_expr (const_tree, hash &); + +} + +/* Compat version until all callers are converted. Return hash for + TREE with SEED. */ +static inline hashval_t iterative_hash_expr(const_tree tree, hashval_t seed) +{ + inchash::hash hstate (seed); + inchash::add_expr (tree, hstate); + return hstate.end (); +} + extern int compare_tree_int (const_tree, unsigned HOST_WIDE_INT); extern int type_list_equal (const_tree, const_tree); extern int chain_member (const_tree, const_tree); @@ -4324,7 +4339,7 @@ extern void using_eh_for_cleanups (void); extern bool using_eh_for_cleanups_p (void); extern const char *get_tree_code_name (enum tree_code); extern void set_call_expr_flags (tree, int); -extern tree walk_tree_1 (tree*, walk_tree_fn, void*, struct pointer_set_t*, +extern tree walk_tree_1 (tree*, walk_tree_fn, void*, hash_set*, walk_tree_lh); extern tree walk_tree_without_duplicates_1 (tree*, walk_tree_fn, void*, walk_tree_lh); diff --git a/main/gcc/ubsan.c b/main/gcc/ubsan.c index 4e7e4878c66..0dbb104d2e8 100644 --- a/main/gcc/ubsan.c +++ b/main/gcc/ubsan.c @@ -49,6 +49,7 @@ along with GCC; see the file COPYING3. If not see #include "intl.h" #include "realmpfr.h" #include "dfp.h" +#include "builtins.h" /* Map from a tree to a VAR_DECL tree. */ @@ -586,7 +587,7 @@ is_ubsan_builtin_p (tree t) /* Expand the UBSAN_BOUNDS special builtin function. */ -void +bool ubsan_expand_bounds_ifn (gimple_stmt_iterator *gsi) { gimple stmt = gsi_stmt (*gsi); @@ -645,21 +646,52 @@ ubsan_expand_bounds_ifn (gimple_stmt_iterator *gsi) /* Point GSI to next logical statement. */ *gsi = gsi_start_bb (fallthru_bb); + return true; } -/* Expand UBSAN_NULL internal call. */ +/* Expand UBSAN_NULL internal call. The type is kept on the ckind + argument which is a constant, because the middle-end treats pointer + conversions as useless and therefore the type of the first argument + could be changed to any other pointer type. */ -void -ubsan_expand_null_ifn (gimple_stmt_iterator gsi) +bool +ubsan_expand_null_ifn (gimple_stmt_iterator *gsip) { + gimple_stmt_iterator gsi = *gsip; gimple stmt = gsi_stmt (gsi); location_t loc = gimple_location (stmt); - gcc_assert (gimple_call_num_args (stmt) == 2); + gcc_assert (gimple_call_num_args (stmt) == 3); tree ptr = gimple_call_arg (stmt, 0); tree ckind = gimple_call_arg (stmt, 1); + tree align = gimple_call_arg (stmt, 2); + tree check_align = NULL_TREE; + bool check_null; basic_block cur_bb = gsi_bb (gsi); + gimple g; + if (!integer_zerop (align)) + { + unsigned int ptralign = get_pointer_alignment (ptr) / BITS_PER_UNIT; + if (compare_tree_int (align, ptralign) == 1) + { + check_align = make_ssa_name (pointer_sized_int_node, NULL); + g = gimple_build_assign_with_ops (NOP_EXPR, check_align, + ptr, NULL_TREE); + gimple_set_location (g, loc); + gsi_insert_before (&gsi, g, GSI_SAME_STMT); + } + } + check_null = (flag_sanitize & SANITIZE_NULL) != 0; + + if (check_align == NULL_TREE && !check_null) + { + gsi_remove (gsip, true); + /* Unlink the UBSAN_NULLs vops before replacing it. */ + unlink_stmt_vdef (stmt); + return true; + } + /* Split the original block holding the pointer dereference. */ edge e = split_block (cur_bb, stmt); @@ -689,12 +721,11 @@ ubsan_expand_null_ifn (gimple_stmt_iterator gsi) /* Update dominance info for the newly created then_bb; note that fallthru_bb's dominance info has already been updated by - split_bock. */ + split_block. */ if (dom_info_available_p (CDI_DOMINATORS)) set_immediate_dominator (CDI_DOMINATORS, then_bb, cond_bb); /* Put the ubsan builtin call into the newly created BB. */ - gimple g; if (flag_sanitize_undefined_trap_on_error) g = gimple_build_call (builtin_decl_implicit (BUILT_IN_TRAP), 0); else @@ -705,54 +736,115 @@ ubsan_expand_null_ifn (gimple_stmt_iterator gsi) : BUILT_IN_UBSAN_HANDLE_TYPE_MISMATCH_ABORT; tree fn = builtin_decl_implicit (bcode); const struct ubsan_mismatch_data m - = { build_zero_cst (pointer_sized_int_node), ckind }; + = { align, fold_convert (unsigned_char_type_node, ckind) }; tree data = ubsan_create_data ("__ubsan_null_data", &loc, &m, - ubsan_type_descriptor (TREE_TYPE (ptr), + ubsan_type_descriptor (TREE_TYPE (ckind), UBSAN_PRINT_POINTER), NULL_TREE); data = build_fold_addr_expr_loc (loc, data); g = gimple_build_call (fn, 2, data, - build_zero_cst (pointer_sized_int_node)); + check_align ? check_align + : build_zero_cst (pointer_sized_int_node)); } - gimple_set_location (g, loc); gimple_stmt_iterator gsi2 = gsi_start_bb (then_bb); + gimple_set_location (g, loc); gsi_insert_after (&gsi2, g, GSI_NEW_STMT); /* Unlink the UBSAN_NULLs vops before replacing it. */ unlink_stmt_vdef (stmt); - g = gimple_build_cond (EQ_EXPR, ptr, build_int_cst (TREE_TYPE (ptr), 0), - NULL_TREE, NULL_TREE); - gimple_set_location (g, loc); + if (check_null) + { + g = gimple_build_cond (EQ_EXPR, ptr, build_int_cst (TREE_TYPE (ptr), 0), + NULL_TREE, NULL_TREE); + gimple_set_location (g, loc); - /* Replace the UBSAN_NULL with a GIMPLE_COND stmt. */ - gsi_replace (&gsi, g, false); -} + /* Replace the UBSAN_NULL with a GIMPLE_COND stmt. */ + gsi_replace (&gsi, g, false); + } -/* Instrument a member call. We check whether 'this' is NULL. */ + if (check_align) + { + if (check_null) + { + /* Split the block with the condition again. */ + e = split_block (cond_bb, stmt); + basic_block cond1_bb = e->src; + basic_block cond2_bb = e->dest; + + /* Make an edge coming from the 'cond1 block' into the 'then block'; + this edge is unlikely taken, so set up the probability + accordingly. */ + e = make_edge (cond1_bb, then_bb, EDGE_TRUE_VALUE); + e->probability = PROB_VERY_UNLIKELY; + + /* Set up the fallthrough basic block. */ + e = find_edge (cond1_bb, cond2_bb); + e->flags = EDGE_FALSE_VALUE; + e->count = cond1_bb->count; + e->probability = REG_BR_PROB_BASE - PROB_VERY_UNLIKELY; + + /* Update dominance info. */ + if (dom_info_available_p (CDI_DOMINATORS)) + { + set_immediate_dominator (CDI_DOMINATORS, fallthru_bb, cond1_bb); + set_immediate_dominator (CDI_DOMINATORS, then_bb, cond1_bb); + } -static void -instrument_member_call (gimple_stmt_iterator *iter) -{ - tree this_parm = gimple_call_arg (gsi_stmt (*iter), 0); - tree kind = build_int_cst (unsigned_char_type_node, UBSAN_MEMBER_CALL); - gimple g = gimple_build_call_internal (IFN_UBSAN_NULL, 2, this_parm, kind); - gimple_set_location (g, gimple_location (gsi_stmt (*iter))); - gsi_insert_before (iter, g, GSI_SAME_STMT); + gsi2 = gsi_start_bb (cond2_bb); + } + + tree mask = build_int_cst (pointer_sized_int_node, + tree_to_uhwi (align) - 1); + g = gimple_build_assign_with_ops (BIT_AND_EXPR, + make_ssa_name (pointer_sized_int_node, + NULL), + check_align, mask); + gimple_set_location (g, loc); + if (check_null) + gsi_insert_after (&gsi2, g, GSI_NEW_STMT); + else + gsi_insert_before (&gsi, g, GSI_SAME_STMT); + + g = gimple_build_cond (NE_EXPR, gimple_assign_lhs (g), + build_int_cst (pointer_sized_int_node, 0), + NULL_TREE, NULL_TREE); + gimple_set_location (g, loc); + if (check_null) + gsi_insert_after (&gsi2, g, GSI_NEW_STMT); + else + /* Replace the UBSAN_NULL with a GIMPLE_COND stmt. */ + gsi_replace (&gsi, g, false); + } + return false; } -/* Instrument a memory reference. T is the pointer, IS_LHS says +/* Instrument a memory reference. BASE is the base of MEM, IS_LHS says whether the pointer is on the left hand side of the assignment. */ static void -instrument_mem_ref (tree t, gimple_stmt_iterator *iter, bool is_lhs) +instrument_mem_ref (tree mem, tree base, gimple_stmt_iterator *iter, + bool is_lhs) { enum ubsan_null_ckind ikind = is_lhs ? UBSAN_STORE_OF : UBSAN_LOAD_OF; - if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (TREE_TYPE (t)))) + unsigned int align = 0; + if (flag_sanitize & SANITIZE_ALIGNMENT) + { + align = min_align_of_type (TREE_TYPE (base)); + if (align <= 1) + align = 0; + } + if (align == 0 && (flag_sanitize & SANITIZE_NULL) == 0) + return; + tree t = TREE_OPERAND (base, 0); + if (!POINTER_TYPE_P (TREE_TYPE (t))) + return; + if (RECORD_OR_UNION_TYPE_P (TREE_TYPE (TREE_TYPE (t))) && mem != base) ikind = UBSAN_MEMBER_ACCESS; - tree kind = build_int_cst (unsigned_char_type_node, ikind); - gimple g = gimple_build_call_internal (IFN_UBSAN_NULL, 2, t, kind); + tree kind = build_int_cst (TREE_TYPE (t), ikind); + tree alignt = build_int_cst (pointer_sized_int_node, align); + gimple g = gimple_build_call_internal (IFN_UBSAN_NULL, 3, t, kind, alignt); gimple_set_location (g, gimple_location (gsi_stmt (*iter))); gsi_insert_before (iter, g, GSI_SAME_STMT); } @@ -764,15 +856,11 @@ instrument_null (gimple_stmt_iterator gsi, bool is_lhs) { gimple stmt = gsi_stmt (gsi); tree t = is_lhs ? gimple_get_lhs (stmt) : gimple_assign_rhs1 (stmt); - t = get_base_address (t); - const enum tree_code code = TREE_CODE (t); + tree base = get_base_address (t); + const enum tree_code code = TREE_CODE (base); if (code == MEM_REF - && TREE_CODE (TREE_OPERAND (t, 0)) == SSA_NAME) - instrument_mem_ref (TREE_OPERAND (t, 0), &gsi, is_lhs); - else if (code == ADDR_EXPR - && POINTER_TYPE_P (TREE_TYPE (t)) - && TREE_CODE (TREE_TYPE (TREE_TYPE (t))) == METHOD_TYPE) - instrument_member_call (&gsi); + && TREE_CODE (TREE_OPERAND (base, 0)) == SSA_NAME) + instrument_mem_ref (t, base, &gsi, is_lhs); } /* Build an ubsan builtin call for the signed-integer-overflow @@ -1147,7 +1235,8 @@ public: virtual bool gate (function *) { return flag_sanitize & (SANITIZE_NULL | SANITIZE_SI_OVERFLOW - | SANITIZE_BOOL | SANITIZE_ENUM) + | SANITIZE_BOOL | SANITIZE_ENUM + | SANITIZE_ALIGNMENT) && current_function_decl != NULL_TREE && !lookup_attribute ("no_sanitize_undefined", DECL_ATTRIBUTES (current_function_decl)); @@ -1180,7 +1269,7 @@ pass_ubsan::execute (function *fun) && is_gimple_assign (stmt)) instrument_si_overflow (gsi); - if (flag_sanitize & SANITIZE_NULL) + if (flag_sanitize & (SANITIZE_NULL | SANITIZE_ALIGNMENT)) { if (gimple_store_p (stmt)) instrument_null (gsi, true); diff --git a/main/gcc/ubsan.h b/main/gcc/ubsan.h index 485449c32ec..c9273237527 100644 --- a/main/gcc/ubsan.h +++ b/main/gcc/ubsan.h @@ -27,7 +27,8 @@ enum ubsan_null_ckind { UBSAN_STORE_OF, UBSAN_REF_BINDING, UBSAN_MEMBER_ACCESS, - UBSAN_MEMBER_CALL + UBSAN_MEMBER_CALL, + UBSAN_CTOR_CALL }; /* This controls how ubsan prints types. Used in ubsan_type_descriptor. */ @@ -43,8 +44,8 @@ struct ubsan_mismatch_data { tree ckind; }; -extern void ubsan_expand_bounds_ifn (gimple_stmt_iterator *); -extern void ubsan_expand_null_ifn (gimple_stmt_iterator); +extern bool ubsan_expand_bounds_ifn (gimple_stmt_iterator *); +extern bool ubsan_expand_null_ifn (gimple_stmt_iterator *); extern tree ubsan_instrument_unreachable (location_t); extern tree ubsan_create_data (const char *, const location_t *, const struct ubsan_mismatch_data *, ...); diff --git a/main/gcc/value-prof.c b/main/gcc/value-prof.c index 0d11db25222..5f6443cdd35 100644 --- a/main/gcc/value-prof.c +++ b/main/gcc/value-prof.c @@ -63,6 +63,7 @@ along with GCC; see the file COPYING3. If not see #include "data-streamer.h" #include "builtins.h" #include "tree-nested.h" +#include "hash-set.h" /* In this file value profile based optimizations are placed. Currently the following optimizations are implemented (for more detailed descriptions @@ -528,10 +529,10 @@ static bool error_found = false; static int visit_hist (void **slot, void *data) { - struct pointer_set_t *visited = (struct pointer_set_t *) data; + hash_set *visited = (hash_set *) data; histogram_value hist = *(histogram_value *) slot; - if (!pointer_set_contains (visited, hist) + if (!visited->contains (hist) && hist->type != HIST_TYPE_TIME_PROFILE) { error ("dead histogram"); @@ -551,10 +552,9 @@ verify_histograms (void) basic_block bb; gimple_stmt_iterator gsi; histogram_value hist; - struct pointer_set_t *visited_hists; error_found = false; - visited_hists = pointer_set_create (); + hash_set visited_hists; FOR_EACH_BB_FN (bb, cfun) for (gsi = gsi_start_bb (bb); !gsi_end_p (gsi); gsi_next (&gsi)) { @@ -571,12 +571,11 @@ verify_histograms (void) dump_histogram_value (stderr, hist); error_found = true; } - pointer_set_insert (visited_hists, hist); + visited_hists.add (hist); } } if (VALUE_HISTOGRAMS (cfun)) - htab_traverse (VALUE_HISTOGRAMS (cfun), visit_hist, visited_hists); - pointer_set_destroy (visited_hists); + htab_traverse (VALUE_HISTOGRAMS (cfun), visit_hist, &visited_hists); if (error_found) internal_error ("verify_histograms failed"); } @@ -1285,7 +1284,17 @@ gimple_mod_subtract_transform (gimple_stmt_iterator *si) return true; } -static pointer_map_t *cgraph_node_map; +static pointer_map_t *cgraph_node_map = 0; + +/* Returns true if node graph is initialized. This + is used to test if profile_id has been created + for cgraph_nodes. */ + +bool +coverage_node_map_initialized_p (void) +{ + return cgraph_node_map != 0; +} /* Initialize map from PROFILE_ID to CGRAPH_NODE. When LOCAL is true, the PROFILE_IDs are computed. when it is false we assume @@ -1301,8 +1310,7 @@ init_node_map (bool local) return; FOR_EACH_DEFINED_FUNCTION (n) - if (n->has_gimple_body_p () - && !n->only_called_directly_p ()) + if (n->has_gimple_body_p ()) { void **val; if (local) diff --git a/main/gcc/var-tracking.c b/main/gcc/var-tracking.c index 00810b956d9..3b72fce9e46 100644 --- a/main/gcc/var-tracking.c +++ b/main/gcc/var-tracking.c @@ -94,6 +94,7 @@ #include "varasm.h" #include "stor-layout.h" #include "pointer-set.h" +#include "hash-map.h" #include "hash-table.h" #include "basic-block.h" #include "tm_p.h" @@ -2019,12 +2020,12 @@ vt_get_canonicalize_base (rtx loc) /* This caches canonicalized addresses for VALUEs, computed using information in the global cselib table. */ -static struct pointer_map_t *global_get_addr_cache; +static hash_map *global_get_addr_cache; /* This caches canonicalized addresses for VALUEs, computed using information from the global cache and information pertaining to a basic block being analyzed. */ -static struct pointer_map_t *local_get_addr_cache; +static hash_map *local_get_addr_cache; static rtx vt_canonicalize_addr (dataflow_set *, rtx); @@ -2036,13 +2037,13 @@ static rtx get_addr_from_global_cache (rtx const loc) { rtx x; - void **slot; gcc_checking_assert (GET_CODE (loc) == VALUE); - slot = pointer_map_insert (global_get_addr_cache, loc); - if (*slot) - return (rtx)*slot; + bool existed; + rtx *slot = &global_get_addr_cache->get_or_insert (loc, &existed); + if (existed) + return *slot; x = canon_rtx (get_addr (loc)); @@ -2056,8 +2057,7 @@ get_addr_from_global_cache (rtx const loc) { /* The table may have moved during recursion, recompute SLOT. */ - slot = pointer_map_contains (global_get_addr_cache, loc); - *slot = x = nx; + *global_get_addr_cache->get (loc) = x = nx; } } @@ -2072,16 +2072,16 @@ static rtx get_addr_from_local_cache (dataflow_set *set, rtx const loc) { rtx x; - void **slot; decl_or_value dv; variable var; location_chain l; gcc_checking_assert (GET_CODE (loc) == VALUE); - slot = pointer_map_insert (local_get_addr_cache, loc); - if (*slot) - return (rtx)*slot; + bool existed; + rtx *slot = &local_get_addr_cache->get_or_insert (loc, &existed); + if (existed) + return *slot; x = get_addr_from_global_cache (loc); @@ -2095,7 +2095,7 @@ get_addr_from_local_cache (dataflow_set *set, rtx const loc) rtx nx = vt_canonicalize_addr (set, x); if (nx != x) { - slot = pointer_map_contains (local_get_addr_cache, loc); + slot = local_get_addr_cache->get (loc); *slot = x = nx; } return x; @@ -2116,7 +2116,7 @@ get_addr_from_local_cache (dataflow_set *set, rtx const loc) rtx nx = vt_canonicalize_addr (set, l->loc); if (x != nx) { - slot = pointer_map_contains (local_get_addr_cache, loc); + slot = local_get_addr_cache->get (loc); *slot = x = nx; } break; @@ -2503,11 +2503,10 @@ val_store (dataflow_set *set, rtx val, rtx loc, rtx insn, bool modified) /* Clear (canonical address) slots that reference X. */ -static bool -local_get_addr_clear_given_value (const void *v ATTRIBUTE_UNUSED, - void **slot, void *x) +bool +local_get_addr_clear_given_value (rtx const &, rtx *slot, rtx x) { - if (vt_get_canonicalize_base ((rtx)*slot) == x) + if (vt_get_canonicalize_base (*slot) == x) *slot = NULL; return true; } @@ -2530,11 +2529,10 @@ val_reset (dataflow_set *set, decl_or_value dv) if (var->onepart == ONEPART_VALUE) { rtx x = dv_as_value (dv); - void **slot; /* Relationships in the global cache don't change, so reset the local cache entry only. */ - slot = pointer_map_contains (local_get_addr_cache, x); + rtx *slot = local_get_addr_cache->get (x); if (slot) { /* If the value resolved back to itself, odds are that other @@ -2543,8 +2541,8 @@ val_reset (dataflow_set *set, decl_or_value dv) old X but resolved to something else remain ok as long as that something else isn't also reset. */ if (*slot == x) - pointer_map_traverse (local_get_addr_cache, - local_get_addr_clear_given_value, x); + local_get_addr_cache + ->traverse (x); *slot = NULL; } } @@ -6660,7 +6658,7 @@ compute_bb_dataflow (basic_block bb) dataflow_set_copy (out, in); if (MAY_HAVE_DEBUG_INSNS) - local_get_addr_cache = pointer_map_create (); + local_get_addr_cache = new hash_map; FOR_EACH_VEC_ELT (VTI (bb)->mos, i, mo) { @@ -6943,7 +6941,7 @@ compute_bb_dataflow (basic_block bb) if (MAY_HAVE_DEBUG_INSNS) { - pointer_map_destroy (local_get_addr_cache); + delete local_get_addr_cache; local_get_addr_cache = NULL; dataflow_set_equiv_regs (out); @@ -9477,13 +9475,13 @@ vt_emit_notes (void) emit_notes_for_differences (BB_HEAD (bb), &cur, &VTI (bb)->in); if (MAY_HAVE_DEBUG_INSNS) - local_get_addr_cache = pointer_map_create (); + local_get_addr_cache = new hash_map; /* Emit the notes for the changes in the basic block itself. */ emit_notes_in_bb (bb, &cur); if (MAY_HAVE_DEBUG_INSNS) - pointer_map_destroy (local_get_addr_cache); + delete local_get_addr_cache; local_get_addr_cache = NULL; /* Free memory occupied by the in hash table, we won't need it @@ -9916,7 +9914,7 @@ vt_initialize (void) valvar_pool = create_alloc_pool ("small variable_def pool", sizeof (struct variable_def), 256); preserved_values.create (256); - global_get_addr_cache = pointer_map_create (); + global_get_addr_cache = new hash_map; } else { @@ -10263,7 +10261,7 @@ vt_finalize (void) if (MAY_HAVE_DEBUG_INSNS) { if (global_get_addr_cache) - pointer_map_destroy (global_get_addr_cache); + delete global_get_addr_cache; global_get_addr_cache = NULL; if (loc_exp_dep_pool) free_alloc_pool (loc_exp_dep_pool); diff --git a/main/gcc/varasm.c b/main/gcc/varasm.c index 27189e1f2a6..399a33b404b 100644 --- a/main/gcc/varasm.c +++ b/main/gcc/varasm.c @@ -51,7 +51,7 @@ along with GCC; see the file COPYING3. If not see #include "common/common-target.h" #include "targhooks.h" #include "cgraph.h" -#include "pointer-set.h" +#include "hash-set.h" #include "l-ipo.h" #include "asan.h" #include "basic-block.h" @@ -2257,7 +2257,7 @@ static bool pending_assemble_externals_processed; /* Avoid O(external_decls**2) lookups in the pending_assemble_externals TREE_LIST in assemble_external. */ -static struct pointer_set_t *pending_assemble_externals_set; +static hash_set *pending_assemble_externals_set; /* True if DECL is a function decl for which no out-of-line copy exists. It is assumed that DECL's assembler name has been set. */ @@ -2311,7 +2311,7 @@ process_pending_assemble_externals (void) pending_assemble_externals = 0; pending_assemble_externals_processed = true; - pointer_set_destroy (pending_assemble_externals_set); + delete pending_assemble_externals_set; #endif } @@ -2376,7 +2376,7 @@ assemble_external (tree decl ATTRIBUTE_UNUSED) return; } - if (! pointer_set_insert (pending_assemble_externals_set, decl)) + if (! pending_assemble_externals_set->add (decl)) pending_assemble_externals = tree_cons (NULL, decl, pending_assemble_externals); #endif @@ -6017,7 +6017,7 @@ init_varasm_once (void) readonly_data_section = text_section; #ifdef ASM_OUTPUT_EXTERNAL - pending_assemble_externals_set = pointer_set_create (); + pending_assemble_externals_set = new hash_set; #endif } diff --git a/main/gcc/varpool.c b/main/gcc/varpool.c index 1e9ccd6591f..bb9c76dfeb1 100644 --- a/main/gcc/varpool.c +++ b/main/gcc/varpool.c @@ -40,6 +40,7 @@ along with GCC; see the file COPYING3. If not see #include "tree-ssa-alias.h" #include "gimple.h" #include "lto-streamer.h" +#include "hash-set.h" const char * const tls_model_names[]={"none", "tls-emulated", "tls-real", "tls-global-dynamic", "tls-local-dynamic", @@ -343,8 +344,16 @@ varpool_node::ctor_useable_for_folding_p (void) /* Variables declared 'const' without an initializer have zero as the initializer if they may not be - overridden at link or run time. */ - if (!DECL_INITIAL (real_node->decl) + overridden at link or run time. + + It is actually requirement for C++ compiler to optimize const variables + consistently. As a GNU extension, do not enfore this rule for user defined + weak variables, so we support interposition on: + static const int dummy = 0; + extern const int foo __attribute__((__weak__, __alias__("dummy"))); + */ + if ((!DECL_INITIAL (real_node->decl) + || (DECL_WEAK (decl) && !DECL_COMDAT (decl))) && (DECL_EXTERNAL (decl) || decl_replaceable_p (decl))) return false; @@ -409,6 +418,7 @@ ctor_for_folding (tree decl) if (decl != real_decl) { gcc_assert (!DECL_INITIAL (decl) + || (node->alias && node->get_alias_target () == real_node) || DECL_INITIAL (decl) == error_mark_node); if (node->weakref) { @@ -580,7 +590,7 @@ varpool_remove_unreferenced_decls (void) varpool_node *first = (varpool_node *)(void *)1; int i; struct ipa_ref *ref = NULL; - struct pointer_set_t *referenced = pointer_set_create (); + hash_set referenced; if (seen_error ()) return; @@ -627,7 +637,7 @@ varpool_remove_unreferenced_decls (void) && vnode->analyzed) enqueue_node (vnode, &first); else - pointer_set_insert (referenced, node); + referenced.add (node); } } if (cgraph_dump_file) @@ -639,13 +649,13 @@ varpool_remove_unreferenced_decls (void) { if (cgraph_dump_file) fprintf (cgraph_dump_file, " %s/%d", node->asm_name (), node->order); - if (pointer_set_contains (referenced, node)) + if (referenced.contains (node)) node->remove_initializer (); else node->remove (); } } - pointer_set_destroy (referenced); + if (cgraph_dump_file) fprintf (cgraph_dump_file, "\n"); } diff --git a/main/libcpp/ChangeLog b/main/libcpp/ChangeLog index 7a6b8e3a5cc..e550d177c26 100644 --- a/main/libcpp/ChangeLog +++ b/main/libcpp/ChangeLog @@ -1,3 +1,10 @@ +2014-07-27 Marek Polacek + + PR c/61861 + * macro.c (builtin_macro): Add location parameter. Set + location of builtin macro to the expansion point. + (enter_macro_context): Pass location to builtin_macro. + 2014-07-16 Dodji Seketeli Support location tracking for built-in macro tokens diff --git a/main/libcpp/macro.c b/main/libcpp/macro.c index 3b8fa406935..556628ba7c7 100644 --- a/main/libcpp/macro.c +++ b/main/libcpp/macro.c @@ -84,7 +84,7 @@ struct macro_arg_token_iter static int enter_macro_context (cpp_reader *, cpp_hashnode *, const cpp_token *, source_location); -static int builtin_macro (cpp_reader *, cpp_hashnode *); +static int builtin_macro (cpp_reader *, cpp_hashnode *, source_location); static void push_ptoken_context (cpp_reader *, cpp_hashnode *, _cpp_buff *, const cpp_token **, unsigned int); static void push_extended_tokens_context (cpp_reader *, cpp_hashnode *, @@ -399,9 +399,10 @@ _cpp_builtin_macro_text (cpp_reader *pfile, cpp_hashnode *node) /* Convert builtin macros like __FILE__ to a token and push it on the context stack. Also handles _Pragma, for which a new token may not be created. Returns 1 if it generates a new token context, 0 to - return the token to the caller. */ + return the token to the caller. LOC is the location of the expansion + point of the macro. */ static int -builtin_macro (cpp_reader *pfile, cpp_hashnode *node) +builtin_macro (cpp_reader *pfile, cpp_hashnode *node, source_location loc) { const uchar *buf; size_t len; @@ -429,6 +430,8 @@ builtin_macro (cpp_reader *pfile, cpp_hashnode *node) /* Set pfile->cur_token as required by _cpp_lex_direct. */ pfile->cur_token = _cpp_temp_token (pfile); cpp_token *token = _cpp_lex_direct (pfile); + /* We should point to the expansion point of the builtin macro. */ + token->src_loc = loc; if (pfile->context->tokens_kind == TOKENS_KIND_EXTENDED) { /* We are tracking tokens resulting from macro expansion. @@ -1212,7 +1215,7 @@ enter_macro_context (cpp_reader *pfile, cpp_hashnode *node, pfile->about_to_expand_macro_p = false; /* Handle built-in macros and the _Pragma operator. */ - return builtin_macro (pfile, node); + return builtin_macro (pfile, node, location); } /* De-allocate the memory used by BUFF which is an array of instances diff --git a/main/libffi/ChangeLog b/main/libffi/ChangeLog index f5fdccb36c4..a2db36614fd 100644 --- a/main/libffi/ChangeLog +++ b/main/libffi/ChangeLog @@ -1,3 +1,8 @@ +2014-07-21 Uros Bizjak + + * src/alpha/ffi.c: Do not include stdlib.h. + (ffi_closure_osf_inner) : Use FFI_ASSERT instead of abort. + 2014-07-04 Thomas Schwinge * testsuite/lib/libffi.exp (libffi-dg-runtest): Change interface diff --git a/main/libffi/src/alpha/ffi.c b/main/libffi/src/alpha/ffi.c index 192f691c4a2..cf0a730afb6 100644 --- a/main/libffi/src/alpha/ffi.c +++ b/main/libffi/src/alpha/ffi.c @@ -27,7 +27,6 @@ #include #include -#include /* Force FFI_TYPE_LONGDOUBLE to be different than FFI_TYPE_DOUBLE; all further uses in this file will refer to the 128-bit type. */ @@ -273,7 +272,7 @@ ffi_closure_osf_inner(ffi_closure *closure, void *rvalue, unsigned long *argp) break; default: - abort (); + FFI_ASSERT (0); } argn += ALIGN(size, FFI_SIZEOF_ARG) / FFI_SIZEOF_ARG; diff --git a/main/libgcc/ChangeLog b/main/libgcc/ChangeLog index c00e6f92dc4..9a3184e6cc1 100644 --- a/main/libgcc/ChangeLog +++ b/main/libgcc/ChangeLog @@ -1,3 +1,100 @@ +2014-08-04 Rohit + + PR target/60102 + * config/rs6000/linux-unwind.h (ppc_fallback_frame_state): Update + based on change in SPE high register numbers and 3 HTM registers. + +2014-08-01 Nathan Sidwell + + * Makefile.in (LIBGCOV_MERGE, LIBGCOV_PROFILER, + LIBGCOV_INTERFACE): Reformat. + * libgcov-driver.c (gcov_exit, __gcov_init): Disable when + IN_GCOV_TOOL. + * libgcov-interface.c: Reformat some comments. + (__gcov_flush_mx): Add declaration. Tidy up definition. + +2014-07-31 Alan Modra + Peter Bergner + + * config/rs6000/ibm-ldouble.c (typedef union longDblUnion): Delete. + (pack_ldouble): New function. + (__gcc_qadd): Use it. + (__gcc_qmul): Likewise. + (__gcc_qdiv): Likewise. + (__gcc_qneg): Likewise. + (__gcc_stoq): Likewise. + (__gcc_dtoq): Likewise. + +2014-07-30 J. D. Johnston + + * config/s390/tpf-unwind.h: Include . + (__tpf_eh_return): Add original return address as second parameter. + Handle cases where unwinder routines were called directly, instead + of from within the C++ library. + +2014-07-29 Nathan Sidwell + + * libgcov.h: Move renaming of entry points to lib gcov specific + portion. + (gcov_do_dump): New rename. + (gcov_rewrite): Remove inline, make HIDDEN. + * libgcov-driver.c (gcov_clear, gcov_exit): Remove declarations. + (gcov_exit_compute_summary): Rename to ... + (compute_summary): ... here. Add LIST argument. + (gcov_exit_merge_gcda): Rename to ... + (merge_one_data): ... here. + (gcov_exit_write_gcda): Rename to ... + (write_one_data): ... here. + (gcov_exit_merge_summary): Rename to ... + (merge_summary): Add RUN_COUNTED argument. + (gcov_exit_dump_gcov): Rename to ... + (dump_one_gcov): Add RUN_COUNTED argument. + (gcov_do_dump): New function, broken out of ... + (gcov_exit): ... here. Call it. + +2014-07-27 Anthony Green + + * config.host: Add moxiebox configuration suppport. + +2014-07-27 Nathan Sidwell + + * libgcov-driver.c (struct gcov_filename_aux): Rename ... + (struct gcov_filename): ... here. Include buffer and max length + fields. + (gcov_max_filename): Remove. + (gi_filename): Remove. + (gcov_exit_compute_summary): Compute max filename here. + (gcov_exit_merge_gcda): Add filename parm, adjust. + (gcov_exit_merge_summary): Likewise. + (gcov_exit_dump_gcov): Adjust for struct gcov_filename changes. + (gcov_exit): Likewise. + (__gcov_init): Don't calculate max length here. + * libgcov_util.c (max_filename_len): Remove. + (read_gcda_file): Don't calculate max length here. + (gcov_read_profile_dir): Don't propagate here. + * libgcov-driver-system.c (alloc_filename_struct): Adjust for + struct gcov_filename changes. + (gcov_exit_open_gcda_file): Likewise. + +2014-07-25 Nathan Sidwell + + * libgcov-driver.c (set_gcov_dump_complete, + reset_gcov_dump_complete, get_gcov_dump_complete): Remove global + functions polluting user's namespace. + (gcov_exit): Set variable directly. + (gcov_clear): Reset variable directly. + * libgcov-interface.c (get_gcov_dymp_complete, + reset_gov_dump_complete): Remove declarations. + (__gcov_reset, __gcov_dump): Don't call them. + +2014-07-24 DJ Delorie + + * config/i386/cygming-crtbegin.c (deregister_frame_fn): Newly public. + (__gcc_deregister_frame): Move logic to detect deregister function + to ... + (__gcc_register_frame): here, so it's consistent with the register + logic. + 2014-07-23 Nathan Sidwell * libgcov-driver.c (set_gcov_list): Remove. diff --git a/main/libgcc/config.host b/main/libgcc/config.host index d7a3e866efa..f4ec792910f 100644 --- a/main/libgcc/config.host +++ b/main/libgcc/config.host @@ -879,9 +879,9 @@ mmix-knuth-mmixware) mn10300-*-*) tmake_file=t-fdpbit ;; -moxie-*-elf | moxie-*-uclinux*) +moxie-*-elf | moxie-*-moxiebox* | moxie-*-uclinux*) tmake_file="moxie/t-moxie t-softfp-sfdf t-softfp-excl t-softfp" - extra_parts="$extra_parts crti.o crtn.o" + extra_parts="$extra_parts crti.o crtn.o crtbegin.o crtend.o" ;; moxie-*-rtems*) tmake_file="$tmake_file moxie/t-moxie t-softfp-sfdf t-softfp-excl t-softfp" diff --git a/main/libgcc/config/i386/cygming-crtbegin.c b/main/libgcc/config/i386/cygming-crtbegin.c index 195b4637637..b27cd0c0a9f 100644 --- a/main/libgcc/config/i386/cygming-crtbegin.c +++ b/main/libgcc/config/i386/cygming-crtbegin.c @@ -102,6 +102,7 @@ static struct object obj; /* Handle of libgcc's DLL reference. */ HANDLE hmod_libgcc; +static void * (*deregister_frame_fn) (const void *) == NULL; #endif #if TARGET_USE_JCR_SECTION @@ -133,9 +134,14 @@ __gcc_register_frame (void) hmod_libgcc = LoadLibrary (LIBGCC_SONAME); register_frame_fn = (void (*) (const void *, struct object *)) GetProcAddress (h, "__register_frame_info"); + deregister_frame_fn = (void* (*) (const void *)) + GetProcAddress (h, "__deregister_frame_info"); + } + else + { + register_frame_fn = __register_frame_info; + deregister_frame_fn = __deregister_frame_info; } - else - register_frame_fn = __register_frame_info; if (register_frame_fn) register_frame_fn (__EH_FRAME_BEGIN__, &obj); #endif @@ -161,13 +167,6 @@ void __gcc_deregister_frame (void) { #if DWARF2_UNWIND_INFO - void * (*deregister_frame_fn) (const void *); - HANDLE h = GetModuleHandle (LIBGCC_SONAME); - if (h) - deregister_frame_fn = (void* (*) (const void *)) - GetProcAddress (h, "__deregister_frame_info"); - else - deregister_frame_fn = __deregister_frame_info; if (deregister_frame_fn) deregister_frame_fn (__EH_FRAME_BEGIN__); if (hmod_libgcc) diff --git a/main/libgcc/config/rs6000/ibm-ldouble.c b/main/libgcc/config/rs6000/ibm-ldouble.c index abcd3c51435..51d58cdae9d 100644 --- a/main/libgcc/config/rs6000/ibm-ldouble.c +++ b/main/libgcc/config/rs6000/ibm-ldouble.c @@ -87,18 +87,30 @@ __asm__ (".symver __gcc_qadd,_xlqadd@GCC_3.4\n\t" ".symver .__gcc_qdiv,._xlqdiv@GCC_3.4"); #endif -typedef union +/* Combine two 'double' values into one 'long double' and return the result. */ +static inline long double +pack_ldouble (double dh, double dl) { - long double ldval; - double dval[2]; -} longDblUnion; +#if defined (__LONG_DOUBLE_128__) \ + && !(defined (_SOFT_FLOAT) || defined (__NO_FPRS__)) + return __builtin_pack_longdouble (dh, dl); +#else + union + { + long double ldval; + double dval[2]; + } x; + x.dval[0] = dh; + x.dval[1] = dl; + return x.ldval; +#endif +} /* Add two 'long double' values and return the result. */ long double __gcc_qadd (double a, double aa, double c, double cc) { - longDblUnion x; - double z, q, zz, xh; + double xh, xl, z, q, zz; z = a + c; @@ -109,12 +121,12 @@ __gcc_qadd (double a, double aa, double c, double cc) z = cc + aa + c + a; if (nonfinite (z)) return z; - x.dval[0] = z; /* Will always be DBL_MAX. */ + xh = z; /* Will always be DBL_MAX. */ zz = aa + cc; if (fabs(a) > fabs(c)) - x.dval[1] = a - z + c + zz; + xl = a - z + c + zz; else - x.dval[1] = c - z + a + zz; + xl = c - z + a + zz; } else { @@ -129,10 +141,9 @@ __gcc_qadd (double a, double aa, double c, double cc) if (nonfinite (xh)) return xh; - x.dval[0] = xh; - x.dval[1] = z - xh + zz; + xl = z - xh + zz; } - return x.ldval; + return pack_ldouble (xh, xl); } long double @@ -148,8 +159,7 @@ static double fmsub (double, double, double); long double __gcc_qmul (double a, double b, double c, double d) { - longDblUnion z; - double t, tau, u, v, w; + double xh, xl, t, tau, u, v, w; t = a * c; /* Highest order double term. */ @@ -173,16 +183,15 @@ __gcc_qmul (double a, double b, double c, double d) /* Construct long double result. */ if (nonfinite (u)) return u; - z.dval[0] = u; - z.dval[1] = (t - u) + tau; - return z.ldval; + xh = u; + xl = (t - u) + tau; + return pack_ldouble (xh, xl); } long double __gcc_qdiv (double a, double b, double c, double d) { - longDblUnion z; - double s, sigma, t, tau, u, v, w; + double xh, xl, s, sigma, t, tau, u, v, w; t = a / c; /* highest order double term */ @@ -219,9 +228,9 @@ __gcc_qdiv (double a, double b, double c, double d) /* Construct long double result. */ if (nonfinite (u)) return u; - z.dval[0] = u; - z.dval[1] = (t - u) + tau; - return z.ldval; + xh = u; + xl = (t - u) + tau; + return pack_ldouble (xh, xl); } #if defined (_SOFT_DOUBLE) && defined (__LONG_DOUBLE_128__) @@ -248,11 +257,7 @@ extern int __gedf2 (double, double); long double __gcc_qneg (double a, double aa) { - longDblUnion x; - - x.dval[0] = -a; - x.dval[1] = -aa; - return x.ldval; + return pack_ldouble (-a, -aa); } /* Compare two 'long double' values for equality. */ @@ -292,24 +297,14 @@ strong_alias (__gcc_qge, __gcc_qgt); long double __gcc_stoq (float a) { - longDblUnion x; - - x.dval[0] = (double) a; - x.dval[1] = 0.0; - - return x.ldval; + return pack_ldouble ((double) a, 0.0); } /* Convert double to long double. */ long double __gcc_dtoq (double a) { - longDblUnion x; - - x.dval[0] = a; - x.dval[1] = 0.0; - - return x.ldval; + return pack_ldouble (a, 0.0); } /* Convert long double to single. */ diff --git a/main/libgcc/config/rs6000/linux-unwind.h b/main/libgcc/config/rs6000/linux-unwind.h index c5b006ee946..ffb4f07eeb6 100644 --- a/main/libgcc/config/rs6000/linux-unwind.h +++ b/main/libgcc/config/rs6000/linux-unwind.h @@ -274,8 +274,8 @@ ppc_fallback_frame_state (struct _Unwind_Context *context, #ifdef __SPE__ for (i = 14; i < 32; i++) { - fs->regs.reg[i + FIRST_PSEUDO_REGISTER - 1].how = REG_SAVED_OFFSET; - fs->regs.reg[i + FIRST_PSEUDO_REGISTER - 1].loc.offset + fs->regs.reg[i + FIRST_SPE_HIGH_REGNO - 4].how = REG_SAVED_OFFSET; + fs->regs.reg[i + FIRST_SPE_HIGH_REGNO - 4].loc.offset = (long) ®s->vregs - new_cfa + 4 * i; } #endif diff --git a/main/libgcc/config/s390/tpf-unwind.h b/main/libgcc/config/s390/tpf-unwind.h index 5fa177b5078..efffda5d434 100644 --- a/main/libgcc/config/s390/tpf-unwind.h +++ b/main/libgcc/config/s390/tpf-unwind.h @@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see . */ #include +#include /* Function Name: __isPATrange Parameters passed into it: address to check @@ -139,29 +140,38 @@ s390_fallback_frame_state (struct _Unwind_Context *context, #define TPFAREA_SIZE STACK_POINTER_OFFSET-TPFAREA_OFFSET #define INVALID_RETURN 0 -void * __tpf_eh_return (void *target); +void * __tpf_eh_return (void *target, void *origRA); void * -__tpf_eh_return (void *target) +__tpf_eh_return (void *target, void *origRA) { Dl_info targetcodeInfo, currentcodeInfo; int retval; void *current, *stackptr, *destination_frame; - unsigned long int shifter, is_a_stub; + unsigned long int shifter; + bool is_a_stub, frameDepth2, firstIteration; - is_a_stub = 0; + is_a_stub = false; + frameDepth2 = false; + firstIteration = true; /* Get code info for target return's address. */ retval = dladdr (target, &targetcodeInfo); + /* Check if original RA is a Pat stub. If so set flag. */ + if (__isPATrange (origRA)) + frameDepth2 = true; + /* Ensure the code info is valid (for target). */ if (retval != INVALID_RETURN) { - - /* Get the stack pointer of the stack frame to be modified by - the exception unwinder. So that we can begin our climb - there. */ - stackptr = (void *) *((unsigned long int *) (*(PREVIOUS_STACK_PTR()))); + /* Get the stack pointer of the first stack frame beyond the + unwinder or if exists the calling C++ runtime function (e.g., + __cxa_throw). */ + if (!frameDepth2) + stackptr = (void *) *((unsigned long int *) (*(PREVIOUS_STACK_PTR()))); + else + stackptr = (void *) *(PREVIOUS_STACK_PTR()); /* Begin looping through stack frames. Stop if invalid code information is retrieved or if a match between the @@ -169,18 +179,26 @@ __tpf_eh_return (void *target) matches that of the target, calculated above. */ do { - /* Get return address based on our stackptr iterator. */ - current = (void *) *((unsigned long int *) - (stackptr+RA_OFFSET)); - - /* Is it a Pat Stub? */ - if (__isPATrange (current)) + if (!frameDepth2 || (frameDepth2 && !firstIteration)) + { + /* Get return address based on our stackptr iterator. */ + current = (void *) *((unsigned long int *) + (stackptr + RA_OFFSET)); + + /* Is it a Pat Stub? */ + if (__isPATrange (current)) + { + /* Yes it was, get real return address in TPF stack area. */ + current = (void *) *((unsigned long int *) + (stackptr + TPFRA_OFFSET)) + is_a_stub = true; + } + } + else { - /* Yes it was, get real return address - in TPF stack area. */ current = (void *) *((unsigned long int *) - (stackptr+TPFRA_OFFSET)); - is_a_stub = 1; + (stackptr + TPFRA_OFFSET)); + is_a_stub = true; } /* Get codeinfo on RA so that we can figure out @@ -219,8 +237,10 @@ __tpf_eh_return (void *target) This is necessary for CTOA stubs. Otherwise we leap one byte past where we want to go to in the TPF pat stub linkage code. */ - shifter = *((unsigned long int *) - (stackptr + RA_OFFSET)); + if (!frameDepth2 || (frameDepth2 && !firstIteration)) + shifter = *((unsigned long int *) (stackptr + RA_OFFSET)); + else + shifter = (unsigned long int) origRA; shifter &= ~1ul; @@ -239,7 +259,8 @@ __tpf_eh_return (void *target) Bump stack frame iterator. */ stackptr = (void *) *(unsigned long int *) stackptr; - is_a_stub = 0; + is_a_stub = false; + firstIteration = false; } while (stackptr && retval != INVALID_RETURN && targetcodeInfo.dli_fbase != currentcodeInfo.dli_fbase); diff --git a/main/libgcc/dyn-ipa.c b/main/libgcc/dyn-ipa.c index fbf40364294..e35766a7613 100644 --- a/main/libgcc/dyn-ipa.c +++ b/main/libgcc/dyn-ipa.c @@ -36,7 +36,7 @@ struct gcov_info; void __gcov_compute_module_groups (void) {} const struct dyn_imp_mod ** gcov_get_sorted_import_module_array (struct gcov_info *mod_info, - unsigned *len) {} + unsigned *len) {return 0;} void gcov_write_module_infos (struct gcov_info *mod_info) {} void diff --git a/main/libgcc/libgcov-driver-system.c b/main/libgcc/libgcov-driver-system.c index d0bed4975b5..5f2db6811d9 100644 --- a/main/libgcc/libgcov-driver-system.c +++ b/main/libgcc/libgcov-driver-system.c @@ -83,55 +83,46 @@ create_file_directory (char *filename) } static void -allocate_filename_struct (struct gcov_filename_aux *gf) +allocate_filename_struct (struct gcov_filename *gf) { const char *gcov_prefix; - int gcov_prefix_strip = 0; size_t prefix_length; - char *gi_filename_up; + int strip = 0; - gcc_assert (gf); { /* Check if the level of dirs to strip off specified. */ char *tmp = getenv("GCOV_PREFIX_STRIP"); if (tmp) { - gcov_prefix_strip = atoi (tmp); + strip = atoi (tmp); /* Do not consider negative values. */ - if (gcov_prefix_strip < 0) - gcov_prefix_strip = 0; + if (strip < 0) + strip = 0; } } + gf->strip = strip; /* Get file name relocation prefix. Non-absolute values are ignored. */ gcov_prefix = getenv("GCOV_PREFIX"); - if (gcov_prefix) - { - prefix_length = strlen(gcov_prefix); - - /* Remove an unnecessary trailing '/' */ - if (IS_DIR_SEPARATOR (gcov_prefix[prefix_length - 1])) - prefix_length--; - } - else - prefix_length = 0; + prefix_length = gcov_prefix ? strlen (gcov_prefix) : 0; + + /* Remove an unnecessary trailing '/' */ + if (prefix_length && IS_DIR_SEPARATOR (gcov_prefix[prefix_length - 1])) + prefix_length--; /* If no prefix was specified and a prefix stip, then we assume relative. */ - if (gcov_prefix_strip != 0 && prefix_length == 0) + if (!prefix_length && gf->strip) { gcov_prefix = "."; prefix_length = 1; } - /* Allocate and initialize the filename scratch space plus one. */ - gi_filename = (char *) xmalloc (prefix_length + gcov_max_filename + 2); - if (prefix_length) - memcpy (gi_filename, gcov_prefix, prefix_length); - gi_filename_up = gi_filename + prefix_length; + gf->prefix = prefix_length; - gf->gi_filename_up = gi_filename_up; - gf->prefix_length = prefix_length; - gf->gcov_prefix_strip = gcov_prefix_strip; + /* Allocate and initialize the filename scratch space. */ + gf->filename = (char *) xmalloc (gf->max_length + prefix_length + 2); + if (prefix_length) + memcpy (gf->filename, gcov_prefix, prefix_length); } static int @@ -155,7 +146,6 @@ gcov_open_by_filename (char *gi_filename) return 0; } - #define GCOV_GET_FILENAME gcov_strip_leading_dirs /* Strip GCOV_PREFIX_STRIP levels of leading '/' from FILENAME and @@ -173,17 +163,20 @@ gcov_strip_leading_dirs (int prefix_length, int gcov_prefix_strip, directories from the initial filename if requested. */ if (gcov_prefix_strip > 0) { - int level = 0; - const char *s = filename; - if (IS_DIR_SEPARATOR(*s)) - ++s; - - /* Skip selected directory levels. */ - for (; (*s != '\0') && (level < gcov_prefix_strip); s++) - if (IS_DIR_SEPARATOR(*s)) + const char *probe = filename; + int level; + + /* Remove a leading separator, without counting it. */ + if (IS_DIR_SEPARATOR (*probe)) + probe++; + + /* Skip selected directory levels. If we fall off the end, we + keep the final part. */ + for (level = gcov_prefix_strip; *probe && level; probe++) + if (IS_DIR_SEPARATOR (*probe)) { - filename = s; - level++; + filename = probe; + level--; } } @@ -198,23 +191,22 @@ gcov_strip_leading_dirs (int prefix_length, int gcov_prefix_strip, strcpy (gi_filename_up, filename); } - /* Open a gcda file specified by GI_FILENAME. Return -1 on error. Return 0 on success. */ static int -gcov_exit_open_gcda_file (struct gcov_info *gi_ptr, struct gcov_filename_aux *gf) +gcov_exit_open_gcda_file (struct gcov_info *gi_ptr, struct gcov_filename *gf) { int gcov_prefix_strip; size_t prefix_length; char *gi_filename_up; - gcov_prefix_strip = gf->gcov_prefix_strip; - gi_filename_up = gf->gi_filename_up; - prefix_length = gf->prefix_length; + gcov_prefix_strip = gf->strip; + gi_filename_up = gf->filename + gf->prefix; + prefix_length = gf->prefix; GCOV_GET_FILENAME (prefix_length, gcov_prefix_strip, gi_ptr->filename, gi_filename_up); - return gcov_open_by_filename (gi_filename); + return gcov_open_by_filename (gf->filename); } diff --git a/main/libgcc/libgcov-driver.c b/main/libgcc/libgcov-driver.c index 143ba2dacf3..dc52cc3268e 100644 --- a/main/libgcc/libgcov-driver.c +++ b/main/libgcc/libgcov-driver.c @@ -119,6 +119,17 @@ struct gcov_summary_buffer struct gcov_summary summary; }; +/* A struct that bundles all the related information about the + gcda filename. */ + +struct gcov_filename +{ + char *filename; /* filename buffer */ + size_t max_length; /* maximum filename length */ + int strip; /* leading chars to strip from filename */ + size_t prefix; /* chars to prepend to filename */ +}; + /* Chain of per-object gcov structures. */ extern struct gcov_info *__gcov_list; @@ -139,32 +150,6 @@ size_t gcov_max_filename = 0; /* Flag when the profile has already been dumped via __gcov_dump(). */ static int gcov_dump_complete; -/* A global function that get the vaule of gcov_dump_complete. */ - -int -get_gcov_dump_complete (void) -{ - return gcov_dump_complete; -} - -/* A global functino that set the vaule of gcov_dump_complete. Will - be used in __gcov_dump() in libgcov-interface.c. */ - -void -set_gcov_dump_complete (void) -{ - gcov_dump_complete = 1; -} - -/* A global functino that set the vaule of gcov_dump_complete. Will - be used in __gcov_reset() in libgcov-interface.c. */ - -void -reset_gcov_dump_complete (void) -{ - gcov_dump_complete = 0; -} - static struct gcov_fn_buffer * free_fn_data (const struct gcov_info *gi_ptr, struct gcov_fn_buffer *buffer, unsigned limit) @@ -369,8 +354,6 @@ gcov_compute_histogram (struct gcov_summary *sum) } } -/* gcda filename. */ -static char *gi_filename; /* buffer for the fn_data from another program. */ static struct gcov_fn_buffer *fn_buffer; /* buffer for summary from other programs to be written out. */ @@ -380,11 +363,13 @@ static struct gcov_summary_buffer *sum_buffer; functions executed once may mistakely become cold. */ static int run_accounted = 0; -/* This funtions computes the program level summary and the histo-gram. - It computes and returns CRC32 and stored summary in THIS_PRG. */ +/* This function computes the program level summary and the histo-gram. + It computes and returns CRC32 and stored summary in THIS_PRG. + Also determines the longest filename length of the info files. */ static gcov_unsigned_t -gcov_exit_compute_summary (struct gcov_summary *this_prg) +compute_summary (struct gcov_info *list, struct gcov_summary *this_prg, + size_t *max_length) { struct gcov_info *gi_ptr; const struct gcov_fn_info *gfi_ptr; @@ -397,8 +382,13 @@ gcov_exit_compute_summary (struct gcov_summary *this_prg) /* Find the totals for this execution. */ memset (this_prg, 0, sizeof (*this_prg)); + *max_length = 0; for (gi_ptr = __gcov_list; gi_ptr; gi_ptr = gi_ptr->next) { + size_t len = strlen (gi_ptr->filename); + if (len > *max_length) + *max_length = len; + crc32 = crc32_unsigned (crc32, gi_ptr->stamp); crc32 = crc32_unsigned (crc32, gi_ptr->n_functions); @@ -439,14 +429,6 @@ gcov_exit_compute_summary (struct gcov_summary *this_prg) return crc32; } -/* A struct that bundles all the related information about the - gcda filename. */ -struct gcov_filename_aux{ - char *gi_filename_up; - int gcov_prefix_strip; - size_t prefix_length; -}; - /* Including system dependent components. */ #include "libgcov-driver-system.c" @@ -455,12 +437,13 @@ struct gcov_filename_aux{ Return -1 on error. In this case, caller will goto read_fatal. */ static int -gcov_exit_merge_gcda (struct gcov_info *gi_ptr, - struct gcov_summary *prg_p, - struct gcov_summary *this_prg, - gcov_position_t *summary_pos_p, - gcov_position_t *eof_pos_p, - gcov_unsigned_t crc32) +merge_one_data (const char *filename, + struct gcov_info *gi_ptr, + struct gcov_summary *prg_p, + struct gcov_summary *this_prg, + gcov_position_t *summary_pos_p, + gcov_position_t *eof_pos_p, + gcov_unsigned_t crc32) { gcov_unsigned_t tag, length; unsigned t_ix; @@ -470,7 +453,7 @@ gcov_exit_merge_gcda (struct gcov_info *gi_ptr, struct gcov_summary_buffer **sum_tail = &sum_buffer; length = gcov_read_unsigned (); - if (!gcov_version (gi_ptr, length, gi_filename)) + if (!gcov_version (gi_ptr, length, filename)) return -1; length = gcov_read_unsigned (); @@ -545,8 +528,7 @@ gcov_exit_merge_gcda (struct gcov_info *gi_ptr, it back out -- we'll be inserting data before this point, so cannot simply keep the data in the file. */ - fn_tail = buffer_fn_data (gi_filename, - gi_ptr, fn_tail, f_ix); + fn_tail = buffer_fn_data (filename, gi_ptr, fn_tail, f_ix); if (!fn_tail) goto read_mismatch; continue; @@ -588,14 +570,14 @@ gcov_exit_merge_gcda (struct gcov_info *gi_ptr, { read_mismatch:; gcov_error ("profiling:%s:Merge mismatch for %s %u\n", - gi_filename, f_ix >= 0 ? "function" : "summary", + filename, f_ix >= 0 ? "function" : "summary", f_ix < 0 ? -1 - f_ix : f_ix); return -1; } return 0; read_error: - gcov_error ("profiling:%s:%s merging\n", gi_filename, + gcov_error ("profiling:%s:%s merging\n", filename, error < 0 ? "Overflow": "Error"); return -1; } @@ -605,10 +587,10 @@ read_error: We will write the file starting from SUMMAY_POS. */ static void -gcov_exit_write_gcda (struct gcov_info *gi_ptr, - const struct gcov_summary *prg_p, - const gcov_position_t eof_pos, - const gcov_position_t summary_pos) +write_one_data (struct gcov_info *gi_ptr, + const struct gcov_summary *prg_p, + const gcov_position_t eof_pos, + const gcov_position_t summary_pos) { unsigned f_ix; struct gcov_summary_buffer *next_sum_buffer; @@ -701,9 +683,10 @@ gcov_exit_write_gcda (struct gcov_info *gi_ptr, Return -1 on error. Return 0 on success. */ static int -gcov_exit_merge_summary (const struct gcov_info *gi_ptr, struct gcov_summary *prg, - struct gcov_summary *this_prg, gcov_unsigned_t crc32, - struct gcov_summary *all_prg __attribute__ ((unused))) +merge_summary (const char *filename, int run_counted, + const struct gcov_info *gi_ptr, struct gcov_summary *prg, + struct gcov_summary *this_prg, gcov_unsigned_t crc32, + struct gcov_summary *all_prg __attribute__ ((unused))) { struct gcov_ctr_summary *cs_prg, *cs_tprg; unsigned t_ix; @@ -722,7 +705,7 @@ gcov_exit_merge_summary (const struct gcov_info *gi_ptr, struct gcov_summary *pr { int first = !cs_prg->runs; - if (!run_accounted) + if (!run_counted) cs_prg->runs++; if (first) cs_prg->num = cs_tprg->num; @@ -739,7 +722,7 @@ gcov_exit_merge_summary (const struct gcov_info *gi_ptr, struct gcov_summary *pr else if (cs_prg->runs) { gcov_error ("profiling:%s:Merge mismatch for summary.\n", - gi_filename); + filename); return -1; } #if !GCOV_LOCKED @@ -765,7 +748,7 @@ gcov_exit_merge_summary (const struct gcov_info *gi_ptr, struct gcov_summary *pr { gcov_error ("profiling:%s:Data file mismatch - some " "data files may have been concurrently " - "updated without locking support\n", gi_filename); + "updated without locking support\n", filename); all_prg->checksum = ~0u; } #endif @@ -855,9 +838,10 @@ gcov_sort_topn_counter_arrays (const struct gcov_info *gi_ptr) summaries separate. */ static void -gcov_exit_dump_gcov (struct gcov_info *gi_ptr, struct gcov_filename_aux *gf, - gcov_unsigned_t crc32, struct gcov_summary *all_prg, - struct gcov_summary *this_prg) +dump_one_gcov (struct gcov_info *gi_ptr, struct gcov_filename *gf, + unsigned run_counted, + gcov_unsigned_t crc32, struct gcov_summary *all_prg, + struct gcov_summary *this_prg) { struct gcov_summary prg; /* summary for this object over all program. */ int error; @@ -880,11 +864,11 @@ gcov_exit_dump_gcov (struct gcov_info *gi_ptr, struct gcov_filename_aux *gf, /* Merge data from file. */ if (tag != GCOV_DATA_MAGIC) { - gcov_error ("profiling:%s:Not a gcov data file\n", gi_filename); + gcov_error ("profiling:%s:Not a gcov data file\n", gf->filename); goto read_fatal; } - error = gcov_exit_merge_gcda (gi_ptr, &prg, this_prg, &summary_pos, &eof_pos, - crc32); + error = merge_one_data (gf->filename, gi_ptr, &prg, this_prg, + &summary_pos, &eof_pos, crc32); if (error == -1) goto read_fatal; } @@ -897,11 +881,12 @@ gcov_exit_dump_gcov (struct gcov_info *gi_ptr, struct gcov_filename_aux *gf, summary_pos = eof_pos; } - error = gcov_exit_merge_summary (gi_ptr, &prg, this_prg, crc32, all_prg); + error = merge_summary (gf->filename, run_counted, gi_ptr, &prg, this_prg, + crc32, all_prg); if (error == -1) goto read_fatal; - gcov_exit_write_gcda (gi_ptr, &prg, eof_pos, summary_pos); + write_one_data (gi_ptr, &prg, eof_pos, summary_pos); /* fall through */ read_fatal:; @@ -912,7 +897,7 @@ read_fatal:; gcov_error (error < 0 ? "profiling:%s:Overflow writing\n" : "profiling:%s:Error writing\n", - gi_filename); + gf->filename); } /* Write imported files (auxiliary modules) for primary module GI_PTR @@ -957,7 +942,7 @@ gcov_write_import_file (char *gi_filename, struct gcov_info *gi_ptr) } static void -gcov_dump_module_info (struct gcov_filename_aux *gf) +gcov_dump_module_info (struct gcov_filename *gf) { struct gcov_info *gi_ptr; @@ -983,8 +968,8 @@ gcov_dump_module_info (struct gcov_filename_aux *gf) if ((error = gcov_close ())) gcov_error (error < 0 ? "profiling:%s:Overflow writing\n" : "profiling:%s:Error writing\n", - gi_filename); - gcov_write_import_file (gi_filename, gi_ptr); + gf->filename); + gcov_write_import_file (gf->filename, gi_ptr); } __gcov_finalize_dyn_callgraph (); } @@ -993,22 +978,17 @@ gcov_dump_module_info (struct gcov_filename_aux *gf) summary and then traverses gcov_list list and dumps the gcov_info objects one by one. */ -void -gcov_exit (void) +void ATTRIBUTE_HIDDEN +gcov_do_dump (struct gcov_info *list, int run_counted) { struct gcov_info *gi_ptr; - struct gcov_filename_aux gf; + struct gcov_filename gf; gcov_unsigned_t crc32; int dump_module_info = 0; struct gcov_summary all_prg; struct gcov_summary this_prg; - /* Prevent the counters from being dumped a second time on exit when the - application already wrote out the profile using __gcov_dump(). */ - if (gcov_dump_complete) - return; - - crc32 = gcov_exit_compute_summary (&this_prg); + crc32 = compute_summary (list, &this_prg, &gf.max_length); allocate_filename_struct (&gf); #if !GCOV_LOCKED @@ -1018,7 +998,7 @@ gcov_exit (void) /* Now merge each file. */ for (gi_ptr = __gcov_list; gi_ptr; gi_ptr = gi_ptr->next) { - gcov_exit_dump_gcov (gi_ptr, &gf, crc32, &all_prg, &this_prg); + dump_one_gcov (gi_ptr, &gf, run_counted, crc32, &all_prg, &this_prg); /* The IS_PRIMARY field is overloaded to indicate if this module is FDO/LIPO. */ @@ -1029,8 +1009,23 @@ gcov_exit (void) if (dump_module_info) gcov_dump_module_info (&gf); - if (gi_filename) - free (gi_filename); + free (gf.filename); +} + +#if !IN_GCOV_TOOL +void +gcov_exit (void) +{ + /* Prevent the counters from being dumped a second time on exit when the + application already wrote out the profile using __gcov_dump(). */ + if (gcov_dump_complete) + return; + + gcov_dump_complete = 1; + + gcov_do_dump (__gcov_list, run_accounted); + + run_accounted = 1; } /* Reset all counters to zero. */ @@ -1040,6 +1035,7 @@ gcov_clear (void) { const struct gcov_info *gi_ptr; + gcov_dump_complete = 0; for (gi_ptr = __gcov_list; gi_ptr; gi_ptr = gi_ptr->next) { unsigned f_ix; @@ -1089,12 +1085,6 @@ __gcov_init (struct gcov_info *info) return; if (gcov_version (info, info->version, 0)) { - size_t filename_length = strlen(info->filename); - - /* Refresh the longest file name information */ - if (filename_length > gcov_max_filename) - gcov_max_filename = filename_length; - /* Assign the module ID (starting at 1). */ info->mod_info->ident = (++gcov_cur_module_id); gcc_assert (EXTRACT_MODULE_ID_FROM_GLOBAL_ID (GEN_FUNC_GLOBAL_ID ( @@ -1109,6 +1099,6 @@ __gcov_init (struct gcov_info *info) } info->version = 0; } - +#endif /* !IN_GCOV_TOOL */ #endif /* L_gcov */ #endif /* inhibit_libc */ diff --git a/main/libgcc/libgcov-interface.c b/main/libgcc/libgcov-interface.c index ab63d9d85c8..a0f3f0d8bad 100644 --- a/main/libgcc/libgcov-interface.c +++ b/main/libgcc/libgcov-interface.c @@ -44,22 +44,21 @@ void __gcov_dump (void) {} extern void gcov_clear (void) ATTRIBUTE_HIDDEN; extern void gcov_exit (void) ATTRIBUTE_HIDDEN; -extern void set_gcov_dump_complete (void) ATTRIBUTE_HIDDEN; -extern void reset_gcov_dump_complete (void) ATTRIBUTE_HIDDEN; +extern __gthread_mutex_t __gcov_flush_mx ATTRIBUTE_HIDDEN; #ifdef L_gcov_flush - #ifdef __GTHREAD_MUTEX_INIT -ATTRIBUTE_HIDDEN __gthread_mutex_t __gcov_flush_mx = __GTHREAD_MUTEX_INIT; +__gthread_mutex_t __gcov_flush_mx = __GTHREAD_MUTEX_INIT; #define init_mx_once() #else -__gthread_mutex_t __gcov_flush_mx ATTRIBUTE_HIDDEN; +__gthread_mutex_t __gcov_flush_mx; static void init_mx (void) { __GTHREAD_MUTEX_INIT_FUNCTION (&__gcov_flush_mx); } + static void init_mx_once (void) { @@ -95,9 +94,6 @@ void __gcov_reset (void) { gcov_clear (); - /* Re-enable dumping to support collecting profile in multiple regions - of interest. */ - reset_gcov_dump_complete (); } #endif /* L_gcov_reset */ @@ -111,8 +107,6 @@ void __gcov_dump (void) { gcov_exit (); - /* Prevent profile from being dumped a second time on application exit. */ - set_gcov_dump_complete (); } #endif /* L_gcov_dump */ @@ -206,8 +200,8 @@ __gcov_execl (const char *path, char *arg, ...) #endif #ifdef L_gcov_execlp -/* A wrapper for the execlp function. Flushes the accumulated profiling data, so - that they are not lost. */ +/* A wrapper for the execlp function. Flushes the accumulated + profiling data, so that they are not lost. */ int __gcov_execlp (const char *path, char *arg, ...) @@ -237,8 +231,8 @@ __gcov_execlp (const char *path, char *arg, ...) #endif #ifdef L_gcov_execle -/* A wrapper for the execle function. Flushes the accumulated profiling data, so - that they are not lost. */ +/* A wrapper for the execle function. Flushes the accumulated + profiling data, so that they are not lost. */ int __gcov_execle (const char *path, char *arg, ...) @@ -270,8 +264,8 @@ __gcov_execle (const char *path, char *arg, ...) #endif #ifdef L_gcov_execv -/* A wrapper for the execv function. Flushes the accumulated profiling data, so - that they are not lost. */ +/* A wrapper for the execv function. Flushes the accumulated + profiling data, so that they are not lost. */ int __gcov_execv (const char *path, char *const argv[]) @@ -282,8 +276,8 @@ __gcov_execv (const char *path, char *const argv[]) #endif #ifdef L_gcov_execvp -/* A wrapper for the execvp function. Flushes the accumulated profiling data, so - that they are not lost. */ +/* A wrapper for the execvp function. Flushes the accumulated + profiling data, so that they are not lost. */ int __gcov_execvp (const char *path, char *const argv[]) @@ -294,8 +288,8 @@ __gcov_execvp (const char *path, char *const argv[]) #endif #ifdef L_gcov_execve -/* A wrapper for the execve function. Flushes the accumulated profiling data, so - that they are not lost. */ +/* A wrapper for the execve function. Flushes the accumulated + profiling data, so that they are not lost. */ int __gcov_execve (const char *path, char *const argv[], char *const envp[]) diff --git a/main/libgcc/libgcov-util.c b/main/libgcc/libgcov-util.c index cb0957a9b08..e275f0ff5c5 100644 --- a/main/libgcc/libgcov-util.c +++ b/main/libgcc/libgcov-util.c @@ -38,7 +38,6 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see extern gcov_position_t gcov_position(); extern int gcov_is_error(); -extern size_t gcov_max_filename; /* Verbose mode for debug. */ static int verbose; @@ -78,8 +77,6 @@ static int k_ctrs_mask[GCOV_COUNTERS]; static struct gcov_ctr_info k_ctrs[GCOV_COUNTERS]; /* Number of kind of counters that have been seen. */ static int k_ctrs_types; -/* The longest length of all the filenames. */ -static int max_filename_len; /* Merge functions for counters. */ #define DEF_GCOV_COUNTER(COUNTER, NAME, FN_TYPE) __gcov_merge ## FN_TYPE, @@ -301,13 +298,11 @@ read_gcda_file (const char *filename) num_fn_info = 0; curr_fn_info = 0; { - char *str_dup = (char*) xmalloc (strlen (filename) + 1); - int len; + size_t len = strlen (filename) + 1; + char *str_dup = (char*) xmalloc (len); - strcpy (str_dup, filename); + memcpy (str_dup, filename, len); obj_info->filename = str_dup; - if ((len = strlen (filename)) > max_filename_len) - max_filename_len = len; } /* Read stamp. */ @@ -433,8 +428,7 @@ read_profile_dir_init (void) /* Driver for read a profile directory and convert into gcov_info list in memory. Return NULL on error, - Return the head of gcov_info list on success. - Note the file static variable GCOV_MAX_FILENAME is also set. */ + Return the head of gcov_info list on success. */ struct gcov_info * gcov_read_profile_dir (const char* dir_name, int recompute_summary ATTRIBUTE_UNUSED) @@ -462,11 +456,6 @@ gcov_read_profile_dir (const char* dir_name, int recompute_summary ATTRIBUTE_UNU free (pwd); - /* gcov_max_filename is defined in libgcov.c that records the - max filename len. We need to set it here to allocate the - array for dumping. */ - gcov_max_filename = max_filename_len; - return gcov_info_head;; } diff --git a/main/libgcc/libgcov.h b/main/libgcc/libgcov.h index 708577ab11f..a8a6b6c00ab 100644 --- a/main/libgcc/libgcov.h +++ b/main/libgcc/libgcov.h @@ -106,6 +106,25 @@ typedef unsigned gcov_type_unsigned __attribute__ ((mode (QI))); #define GCOV_LOCKED 0 #endif +/* In libgcov we need these functions to be extern, so prefix them with + __gcov. In libgcov they must also be hidden so that the instance in + the executable is not also used in a DSO. */ +#define gcov_var __gcov_var +#define gcov_open __gcov_open +#define gcov_close __gcov_close +#define gcov_write_tag_length __gcov_write_tag_length +#define gcov_position __gcov_position +#define gcov_seek __gcov_seek +#define gcov_rewrite __gcov_rewrite +#define gcov_is_error __gcov_is_error +#define gcov_write_unsigned __gcov_write_unsigned +#define gcov_write_counter __gcov_write_counter +#define gcov_write_summary __gcov_write_summary +#define gcov_read_unsigned __gcov_read_unsigned +#define gcov_read_counter __gcov_read_counter +#define gcov_read_summary __gcov_read_summary +#define gcov_do_dump __gcov_do_dump + #else /* IN_GCOV_TOOL */ /* About the host. */ /* This path will be compiled for the host and linked into diff --git a/main/libgfortran/ChangeLog b/main/libgfortran/ChangeLog index 80f87523a69..77afd166d07 100644 --- a/main/libgfortran/ChangeLog +++ b/main/libgfortran/ChangeLog @@ -1,3 +1,7 @@ +2014-08-04 Jakub Jelinek + + * runtime/memory.c (xmallocarray): Avoid division for the common case. + 2014-07-20 Jerry DeLisle PR libgfortran/61632 diff --git a/main/libgfortran/runtime/memory.c b/main/libgfortran/runtime/memory.c index 501d870b83c..16f06065e2b 100644 --- a/main/libgfortran/runtime/memory.c +++ b/main/libgfortran/runtime/memory.c @@ -56,7 +56,9 @@ xmallocarray (size_t nmemb, size_t size) if (!nmemb || !size) size = nmemb = 1; - else if (nmemb > SIZE_MAX / size) +#define HALF_SIZE_T (((size_t) 1) << (__CHAR_BIT__ * sizeof (size_t) / 2)) + else if (__builtin_expect ((nmemb | size) >= HALF_SIZE_T, 0) + && nmemb > SIZE_MAX / size) { errno = ENOMEM; os_error ("Integer overflow in xmallocarray"); diff --git a/main/libgo/runtime/go-caller.c b/main/libgo/runtime/go-caller.c index a5c687d00f4..7fcdf2021d3 100644 --- a/main/libgo/runtime/go-caller.c +++ b/main/libgo/runtime/go-caller.c @@ -7,6 +7,9 @@ /* Implement runtime.Caller. */ #include +#include +#include +#include #include "backtrace.h" @@ -99,6 +102,7 @@ __go_get_backtrace_state () if (back_state == NULL) { const char *filename; + struct stat s; filename = (const char *) runtime_progname (); @@ -108,6 +112,14 @@ __go_get_backtrace_state () if (__builtin_strchr (filename, '/') == NULL) filename = NULL; + /* If the file is small, then it's not the real executable. + This is specifically to deal with Docker, which uses a bogus + argv[0] (http://gcc.gnu.org/PR61895). It would be nice to + have a better check for whether this file is the real + executable. */ + if (stat (filename, &s) < 0 || s.st_size < 1024) + filename = NULL; + back_state = backtrace_create_state (filename, 1, error_callback, NULL); } runtime_unlock (&back_state_lock); diff --git a/main/libgo/runtime/mem.c b/main/libgo/runtime/mem.c index 8e374863b8e..6312480b69d 100644 --- a/main/libgo/runtime/mem.c +++ b/main/libgo/runtime/mem.c @@ -47,7 +47,7 @@ addrspace_free(void *v __attribute__ ((unused)), uintptr n __attribute__ ((unuse chunk = page_size * sizeof vec; if(chunk > (n - off)) chunk = n - off; - errval = mincore((int8*)v + off, chunk, vec); + errval = mincore((char*)v + off, chunk, (void*)vec); // ENOMEM means unmapped, which is what we want. // Anything else we assume means the pages are mapped. if(errval == 0 || errno != ENOMEM) diff --git a/main/libgomp/ChangeLog b/main/libgomp/ChangeLog index e79ca256f9b..ee73689e702 100644 --- a/main/libgomp/ChangeLog +++ b/main/libgomp/ChangeLog @@ -1,7 +1,48 @@ +2014-08-04 Jakub Jelinek + + * task.c (GOMP_taskgroup_end): If taskgroup->num_children + is not zero, but taskgroup->children is NULL and there are + any task->children, schedule those instead of waiting. + * testsuite/libgomp.c/depend-6.c: New test. + * testsuite/libgomp.c/depend-7.c: New test. + * testsuite/libgomp.c/depend-8.c: New test. + * testsuite/libgomp.c/depend-9.c: New test. + * testsuite/libgomp.c/depend-10.c: New test. + +2014-08-01 Jakub Jelinek + + * libgomp.h (struct gomp_task_depend_entry): Add redundant_out field. + (struct gomp_taskwait): New type. + (struct gomp_task): Add taskwait and parent_depends_on, remove + in_taskwait and taskwait_sem fields. + (gomp_finish_task): Don't destroy taskwait_sem. + * task.c (gomp_init_task): Don't init in_taskwait, instead init + taskwait and parent_depends_on. + (GOMP_task): For if (0) tasks with depend clause that depend on + earlier tasks don't defer them, instead call + gomp_task_maybe_wait_for_dependencies to wait for the dependencies. + Initialize redundant_out field, for redundant out entries just + move them at the end of linked list instead of removing them + completely, and set redundant_out flag instead of redundant. + (gomp_task_run_pre): Update last_parent_depends_on if scheduling + that task. + (gomp_task_run_post_handle_dependers): If parent is in + gomp_task_maybe_wait_for_dependencies and newly runnable task + is not parent_depends_on, queue it in parent->children linked + list after all runnable tasks with parent_depends_on set. + Adjust for addition of taskwait indirection. + (gomp_task_run_post_remove_parent): If parent is in + gomp_task_maybe_wait_for_dependencies and task to be removed + is parent_depends_on, decrement n_depend and if needed awake + parent. Adjust for addition of taskwait indirection. + (GOMP_taskwait): Adjust for addition of taskwait indirection. + (gomp_task_maybe_wait_for_dependencies): New function. + * testsuite/libgomp.c/depend-5.c: New test. + 2014-07-13 Tobias Burnus * testsuite/libgomp.fortran/pr34020.f90: Make compile - with TS 18508/Fortran 2015 + with TS 18508/Fortran 2015. 2014-07-06 Marek Polacek diff --git a/main/libgomp/libgomp.h b/main/libgomp/libgomp.h index bcd5b3448ce..a1482ccfbf4 100644 --- a/main/libgomp/libgomp.h +++ b/main/libgomp/libgomp.h @@ -274,6 +274,7 @@ struct gomp_task_depend_entry struct gomp_task *task; bool is_in; bool redundant; + bool redundant_out; }; struct gomp_dependers_vec @@ -283,6 +284,17 @@ struct gomp_dependers_vec struct gomp_task *elem[]; }; +/* Used when in GOMP_taskwait or in gomp_task_maybe_wait_for_dependencies. */ + +struct gomp_taskwait +{ + bool in_taskwait; + bool in_depend_wait; + size_t n_depend; + struct gomp_task *last_parent_depends_on; + gomp_sem_t taskwait_sem; +}; + /* This structure describes a "task" to be run by a thread. */ struct gomp_task @@ -298,17 +310,17 @@ struct gomp_task struct gomp_taskgroup *taskgroup; struct gomp_dependers_vec *dependers; struct htab *depend_hash; + struct gomp_taskwait *taskwait; size_t depend_count; size_t num_dependees; struct gomp_task_icv icv; void (*fn) (void *); void *fn_data; enum gomp_task_kind kind; - bool in_taskwait; bool in_tied_task; bool final_task; bool copy_ctors_done; - gomp_sem_t taskwait_sem; + bool parent_depends_on; struct gomp_task_depend_entry depend[]; }; @@ -582,7 +594,6 @@ gomp_finish_task (struct gomp_task *task) { if (__builtin_expect (task->depend_hash != NULL, 0)) free (task->depend_hash); - gomp_sem_destroy (&task->taskwait_sem); } /* team.c */ diff --git a/main/libgomp/task.c b/main/libgomp/task.c index be2df3f2f60..7d3233c6e1b 100644 --- a/main/libgomp/task.c +++ b/main/libgomp/task.c @@ -66,16 +66,16 @@ gomp_init_task (struct gomp_task *task, struct gomp_task *parent_task, task->parent = parent_task; task->icv = *prev_icv; task->kind = GOMP_TASK_IMPLICIT; - task->in_taskwait = false; + task->taskwait = NULL; task->in_tied_task = false; task->final_task = false; task->copy_ctors_done = false; + task->parent_depends_on = false; task->children = NULL; task->taskgroup = NULL; task->dependers = NULL; task->depend_hash = NULL; task->depend_count = 0; - gomp_sem_init (&task->taskwait_sem, 0); } /* Clean up a task, after completing it. */ @@ -104,6 +104,8 @@ gomp_clear_parent (struct gomp_task *children) while (task != children); } +static void gomp_task_maybe_wait_for_dependencies (void **depend); + /* Called when encountering an explicit task directive. If IF_CLAUSE is false, then we must not delay in executing the task. If UNTIED is true, then the task may be executed by any member of the team. */ @@ -141,35 +143,12 @@ GOMP_task (void (*fn) (void *), void *data, void (*cpyfn) (void *, void *), /* If there are depend clauses and earlier deferred sibling tasks with depend clauses, check if there isn't a dependency. If there - is, fall through to the deferred task handling, as we can't - schedule such tasks right away. There is no need to handle + is, we need to wait for them. There is no need to handle depend clauses for non-deferred tasks other than this, because the parent task is suspended until the child task finishes and thus it can't start further child tasks. */ if ((flags & 8) && thr->task && thr->task->depend_hash) - { - struct gomp_task *parent = thr->task; - struct gomp_task_depend_entry elem, *ent = NULL; - size_t ndepend = (uintptr_t) depend[0]; - size_t nout = (uintptr_t) depend[1]; - size_t i; - gomp_mutex_lock (&team->task_lock); - for (i = 0; i < ndepend; i++) - { - elem.addr = depend[i + 2]; - ent = htab_find (parent->depend_hash, &elem); - for (; ent; ent = ent->next) - if (i >= nout && ent->is_in) - continue; - else - break; - if (ent) - break; - } - gomp_mutex_unlock (&team->task_lock); - if (ent) - goto defer; - } + gomp_task_maybe_wait_for_dependencies (depend); gomp_init_task (&task, thr->task, gomp_icv (false)); task.kind = GOMP_TASK_IFFALSE; @@ -209,7 +188,6 @@ GOMP_task (void (*fn) (void *), void *data, void (*cpyfn) (void *, void *), } else { - defer:; struct gomp_task *task; struct gomp_task *parent = thr->task; struct gomp_taskgroup *taskgroup = parent->taskgroup; @@ -275,11 +253,12 @@ GOMP_task (void (*fn) (void *), void *data, void (*cpyfn) (void *, void *), task->depend[i].task = task; task->depend[i].is_in = i >= nout; task->depend[i].redundant = false; + task->depend[i].redundant_out = false; hash_entry_type *slot = htab_find_slot (&parent->depend_hash, &task->depend[i], INSERT); - hash_entry_type out = NULL; + hash_entry_type out = NULL, last = NULL; if (*slot) { /* If multiple depends on the same task are the @@ -294,6 +273,11 @@ GOMP_task (void (*fn) (void *), void *data, void (*cpyfn) (void *, void *), } for (ent = *slot; ent; ent = ent->next) { + if (ent->redundant_out) + break; + + last = ent; + /* depend(in:...) doesn't depend on earlier depend(in:...). */ if (i >= nout && ent->is_in) @@ -341,21 +325,31 @@ GOMP_task (void (*fn) (void *), void *data, void (*cpyfn) (void *, void *), *slot = &task->depend[i]; /* There is no need to store more than one depend({,in}out:) - task per address in the hash table chain, because each out + task per address in the hash table chain for the purpose + of creation of deferred tasks, because each out depends on all earlier outs, thus it is enough to record just the last depend({,in}out:). For depend(in:), we need to keep all of the previous ones not terminated yet, because a later depend({,in}out:) might need to depend on all of them. So, if the new task's clause is depend({,in}out:), we know there is at most one other depend({,in}out:) clause - in the list (out) and to maintain the invariant we now - need to remove it from the list. */ + in the list (out). For non-deferred tasks we want to see + all outs, so they are moved to the end of the chain, + after first redundant_out entry all following entries + should be redundant_out. */ if (!task->depend[i].is_in && out) { - if (out->next) - out->next->prev = out->prev; - out->prev->next = out->next; - out->redundant = true; + if (out != last) + { + out->next->prev = out->prev; + out->prev->next = out->next; + out->next = last->next; + out->prev = last; + last->next = out; + if (out->next) + out->next->prev = out; + } + out->redundant_out = true; } } if (task->num_dependees) @@ -421,8 +415,20 @@ static inline bool gomp_task_run_pre (struct gomp_task *child_task, struct gomp_task *parent, struct gomp_taskgroup *taskgroup, struct gomp_team *team) { - if (parent && parent->children == child_task) - parent->children = child_task->next_child; + if (parent) + { + if (parent->children == child_task) + parent->children = child_task->next_child; + if (__builtin_expect (child_task->parent_depends_on, 0) + && parent->taskwait->last_parent_depends_on == child_task) + { + if (child_task->prev_child->kind == GOMP_TASK_WAITING + && child_task->prev_child->parent_depends_on) + parent->taskwait->last_parent_depends_on = child_task->prev_child; + else + parent->taskwait->last_parent_depends_on = NULL; + } + } if (taskgroup && taskgroup->children == child_task) taskgroup->children = child_task->next_taskgroup; child_task->prev_queue->next_queue = child_task->next_queue; @@ -489,8 +495,23 @@ gomp_task_run_post_handle_dependers (struct gomp_task *child_task, { if (parent->children) { - task->next_child = parent->children; - task->prev_child = parent->children->prev_child; + /* If parent is in gomp_task_maybe_wait_for_dependencies + and it doesn't need to wait for this task, put it after + all ready to run tasks it needs to wait for. */ + if (parent->taskwait && parent->taskwait->last_parent_depends_on + && !task->parent_depends_on) + { + struct gomp_task *last_parent_depends_on + = parent->taskwait->last_parent_depends_on; + task->next_child = last_parent_depends_on->next_child; + task->prev_child = last_parent_depends_on; + } + else + { + task->next_child = parent->children; + task->prev_child = parent->children->prev_child; + parent->children = task; + } task->next_child->prev_child = task; task->prev_child->next_child = task; } @@ -498,12 +519,23 @@ gomp_task_run_post_handle_dependers (struct gomp_task *child_task, { task->next_child = task; task->prev_child = task; + parent->children = task; } - parent->children = task; - if (parent->in_taskwait) + if (parent->taskwait) { - parent->in_taskwait = false; - gomp_sem_post (&parent->taskwait_sem); + if (parent->taskwait->in_taskwait) + { + parent->taskwait->in_taskwait = false; + gomp_sem_post (&parent->taskwait->taskwait_sem); + } + else if (parent->taskwait->in_depend_wait) + { + parent->taskwait->in_depend_wait = false; + gomp_sem_post (&parent->taskwait->taskwait_sem); + } + if (parent->taskwait->last_parent_depends_on == NULL + && task->parent_depends_on) + parent->taskwait->last_parent_depends_on = task; } } if (taskgroup) @@ -575,6 +607,13 @@ gomp_task_run_post_remove_parent (struct gomp_task *child_task) struct gomp_task *parent = child_task->parent; if (parent == NULL) return; + if (__builtin_expect (child_task->parent_depends_on, 0) + && --parent->taskwait->n_depend == 0 + && parent->taskwait->in_depend_wait) + { + parent->taskwait->in_depend_wait = false; + gomp_sem_post (&parent->taskwait->taskwait_sem); + } child_task->prev_child->next_child = child_task->next_child; child_task->next_child->prev_child = child_task->prev_child; if (parent->children != child_task) @@ -589,10 +628,10 @@ gomp_task_run_post_remove_parent (struct gomp_task *child_task) written by child_task->fn above is flushed before the NULL is written. */ __atomic_store_n (&parent->children, NULL, MEMMODEL_RELEASE); - if (parent->in_taskwait) + if (parent->taskwait && parent->taskwait->in_taskwait) { - parent->in_taskwait = false; - gomp_sem_post (&parent->taskwait_sem); + parent->taskwait->in_taskwait = false; + gomp_sem_post (&parent->taskwait->taskwait_sem); } } } @@ -736,6 +775,7 @@ GOMP_taskwait (void) struct gomp_task *task = thr->task; struct gomp_task *child_task = NULL; struct gomp_task *to_free = NULL; + struct gomp_taskwait taskwait; int do_wake = 0; /* The acquire barrier on load of task->children here synchronizes @@ -748,18 +788,194 @@ GOMP_taskwait (void) || __atomic_load_n (&task->children, MEMMODEL_ACQUIRE) == NULL) return; + memset (&taskwait, 0, sizeof (taskwait)); gomp_mutex_lock (&team->task_lock); while (1) { bool cancelled = false; if (task->children == NULL) { + bool destroy_taskwait = task->taskwait != NULL; + task->taskwait = NULL; gomp_mutex_unlock (&team->task_lock); if (to_free) { gomp_finish_task (to_free); free (to_free); } + if (destroy_taskwait) + gomp_sem_destroy (&taskwait.taskwait_sem); + return; + } + if (task->children->kind == GOMP_TASK_WAITING) + { + child_task = task->children; + cancelled + = gomp_task_run_pre (child_task, task, child_task->taskgroup, + team); + if (__builtin_expect (cancelled, 0)) + { + if (to_free) + { + gomp_finish_task (to_free); + free (to_free); + to_free = NULL; + } + goto finish_cancelled; + } + } + else + { + /* All tasks we are waiting for are already running + in other threads. Wait for them. */ + if (task->taskwait == NULL) + { + taskwait.in_depend_wait = false; + gomp_sem_init (&taskwait.taskwait_sem, 0); + task->taskwait = &taskwait; + } + taskwait.in_taskwait = true; + } + gomp_mutex_unlock (&team->task_lock); + if (do_wake) + { + gomp_team_barrier_wake (&team->barrier, do_wake); + do_wake = 0; + } + if (to_free) + { + gomp_finish_task (to_free); + free (to_free); + to_free = NULL; + } + if (child_task) + { + thr->task = child_task; + child_task->fn (child_task->fn_data); + thr->task = task; + } + else + gomp_sem_wait (&taskwait.taskwait_sem); + gomp_mutex_lock (&team->task_lock); + if (child_task) + { + finish_cancelled:; + size_t new_tasks + = gomp_task_run_post_handle_depend (child_task, team); + child_task->prev_child->next_child = child_task->next_child; + child_task->next_child->prev_child = child_task->prev_child; + if (task->children == child_task) + { + if (child_task->next_child != child_task) + task->children = child_task->next_child; + else + task->children = NULL; + } + gomp_clear_parent (child_task->children); + gomp_task_run_post_remove_taskgroup (child_task); + to_free = child_task; + child_task = NULL; + team->task_count--; + if (new_tasks > 1) + { + do_wake = team->nthreads - team->task_running_count + - !task->in_tied_task; + if (do_wake > new_tasks) + do_wake = new_tasks; + } + } + } +} + +/* This is like GOMP_taskwait, but we only wait for tasks that the + upcoming task depends on. */ + +static void +gomp_task_maybe_wait_for_dependencies (void **depend) +{ + struct gomp_thread *thr = gomp_thread (); + struct gomp_task *task = thr->task; + struct gomp_team *team = thr->ts.team; + struct gomp_task_depend_entry elem, *ent = NULL; + struct gomp_taskwait taskwait; + struct gomp_task *last_parent_depends_on = NULL; + size_t ndepend = (uintptr_t) depend[0]; + size_t nout = (uintptr_t) depend[1]; + size_t i; + size_t num_awaited = 0; + struct gomp_task *child_task = NULL; + struct gomp_task *to_free = NULL; + int do_wake = 0; + + gomp_mutex_lock (&team->task_lock); + for (i = 0; i < ndepend; i++) + { + elem.addr = depend[i + 2]; + ent = htab_find (task->depend_hash, &elem); + for (; ent; ent = ent->next) + if (i >= nout && ent->is_in) + continue; + else + { + struct gomp_task *tsk = ent->task; + if (!tsk->parent_depends_on) + { + tsk->parent_depends_on = true; + ++num_awaited; + if (tsk->num_dependees == 0 && tsk->kind == GOMP_TASK_WAITING) + { + /* If a task we need to wait for is not already + running and is ready to be scheduled, move it + to front, so that we run it as soon as possible. */ + if (last_parent_depends_on) + { + tsk->prev_child->next_child = tsk->next_child; + tsk->next_child->prev_child = tsk->prev_child; + tsk->prev_child = last_parent_depends_on; + tsk->next_child = last_parent_depends_on->next_child; + tsk->prev_child->next_child = tsk; + tsk->next_child->prev_child = tsk; + } + else if (tsk != task->children) + { + tsk->prev_child->next_child = tsk->next_child; + tsk->next_child->prev_child = tsk->prev_child; + tsk->prev_child = task->children; + tsk->next_child = task->children->next_child; + task->children = tsk; + tsk->prev_child->next_child = tsk; + tsk->next_child->prev_child = tsk; + } + last_parent_depends_on = tsk; + } + } + } + } + if (num_awaited == 0) + { + gomp_mutex_unlock (&team->task_lock); + return; + } + + memset (&taskwait, 0, sizeof (taskwait)); + taskwait.n_depend = num_awaited; + taskwait.last_parent_depends_on = last_parent_depends_on; + gomp_sem_init (&taskwait.taskwait_sem, 0); + task->taskwait = &taskwait; + + while (1) + { + bool cancelled = false; + if (taskwait.n_depend == 0) + { + task->taskwait = NULL; + gomp_mutex_unlock (&team->task_lock); + if (to_free) + { + gomp_finish_task (to_free); + free (to_free); + } + gomp_sem_destroy (&taskwait.taskwait_sem); return; } if (task->children->kind == GOMP_TASK_WAITING) @@ -782,7 +998,7 @@ GOMP_taskwait (void) else /* All tasks we are waiting for are already running in other threads. Wait for them. */ - task->in_taskwait = true; + taskwait.in_depend_wait = true; gomp_mutex_unlock (&team->task_lock); if (do_wake) { @@ -802,13 +1018,15 @@ GOMP_taskwait (void) thr->task = task; } else - gomp_sem_wait (&task->taskwait_sem); + gomp_sem_wait (&taskwait.taskwait_sem); gomp_mutex_lock (&team->task_lock); if (child_task) { finish_cancelled:; size_t new_tasks = gomp_task_run_post_handle_depend (child_task, team); + if (child_task->parent_depends_on) + --taskwait.n_depend; child_task->prev_child->next_child = child_task->next_child; child_task->next_child->prev_child = child_task->prev_child; if (task->children == child_task) @@ -897,18 +1115,26 @@ GOMP_taskgroup_end (void) if (taskgroup->children == NULL) { if (taskgroup->num_children) - goto do_wait; - gomp_mutex_unlock (&team->task_lock); - if (to_free) { - gomp_finish_task (to_free); - free (to_free); + if (task->children == NULL) + goto do_wait; + child_task = task->children; + } + else + { + gomp_mutex_unlock (&team->task_lock); + if (to_free) + { + gomp_finish_task (to_free); + free (to_free); + } + goto finish; } - goto finish; } - if (taskgroup->children->kind == GOMP_TASK_WAITING) + else + child_task = taskgroup->children; + if (child_task->kind == GOMP_TASK_WAITING) { - child_task = taskgroup->children; cancelled = gomp_task_run_pre (child_task, child_task->parent, taskgroup, team); @@ -925,6 +1151,7 @@ GOMP_taskgroup_end (void) } else { + child_task = NULL; do_wait: /* All tasks we are waiting for are already running in other threads. Wait for them. */ @@ -956,20 +1183,9 @@ GOMP_taskgroup_end (void) finish_cancelled:; size_t new_tasks = gomp_task_run_post_handle_depend (child_task, team); - child_task->prev_taskgroup->next_taskgroup - = child_task->next_taskgroup; - child_task->next_taskgroup->prev_taskgroup - = child_task->prev_taskgroup; - --taskgroup->num_children; - if (taskgroup->children == child_task) - { - if (child_task->next_taskgroup != child_task) - taskgroup->children = child_task->next_taskgroup; - else - taskgroup->children = NULL; - } gomp_task_run_post_remove_parent (child_task); gomp_clear_parent (child_task->children); + gomp_task_run_post_remove_taskgroup (child_task); to_free = child_task; child_task = NULL; team->task_count--; diff --git a/main/libgomp/testsuite/libgomp.c/depend-10.c b/main/libgomp/testsuite/libgomp.c/depend-10.c new file mode 100644 index 00000000000..2137bf9471d --- /dev/null +++ b/main/libgomp/testsuite/libgomp.c/depend-10.c @@ -0,0 +1,3 @@ +/* { dg-set-target-env-var OMP_NUM_THREADS "1" } */ + +#include "depend-5.c" diff --git a/main/libgomp/testsuite/libgomp.c/depend-5.c b/main/libgomp/testsuite/libgomp.c/depend-5.c new file mode 100644 index 00000000000..192c6ddfeba --- /dev/null +++ b/main/libgomp/testsuite/libgomp.c/depend-5.c @@ -0,0 +1,98 @@ +#include + +__attribute__((noinline, noclone)) void +f1 (int ifval) +{ + int x = 1, y = 2, z = 3; + #pragma omp parallel + #pragma omp single + { + #pragma omp task shared (x) depend(out: x) + x = 2; + #pragma omp task shared (x) depend(inout: x) + { + if (x != 2) + abort (); + x = 3; + } + #pragma omp task shared (x) depend(inout: x) + { + if (x != 3) + abort (); + x = 4; + } + #pragma omp task shared (z) depend(in: z) + if (z != 3) + abort (); + #pragma omp task shared (z) depend(in: z) + if (z != 3) + abort (); + #pragma omp task shared (z) depend(in: z) + if (z != 3) + abort (); + #pragma omp task shared (z) depend(in: z) + if (z != 3) + abort (); + #pragma omp task shared (z) depend(in: z) + if (z != 3) + abort (); + #pragma omp task shared (z) depend(in: z) + if (z != 3) + abort (); + #pragma omp task shared (y) depend(in: y) + if (y != 2) + abort (); + #pragma omp task shared (y) depend(in: y) + if (y != 2) + abort (); + #pragma omp task shared (y) depend(in: y) + if (y != 2) + abort (); + #pragma omp task shared (y) depend(in: y) + if (y != 2) + abort (); + #pragma omp task if (ifval) shared (x, y) depend(in: x) depend(inout: y) + { + if (x != 4 || y != 2) + abort (); + y = 3; + } + if (ifval == 0) + { + /* The above if (0) task should have waited till all + the tasks with x and y dependencies finish. */ + if (x != 4 || y != 3) + abort (); + x = 5; + y = 4; + } + #pragma omp task shared (z) depend(inout: z) + { + if (z != 3) + abort (); + z = 4; + } + #pragma omp task shared (z) depend(inout: z) + { + if (z != 4) + abort (); + z = 5; + } + #pragma omp taskwait + if (x != (ifval ? 4 : 5) || y != (ifval ? 3 : 4) || z != 5) + abort (); + #pragma omp task if (ifval) shared (x, y) depend(in: x) depend(inout: y) + { + if (x != (ifval ? 4 : 5) || y != (ifval ? 3 : 4)) + abort (); + } + } +} + +int +main () +{ + f1 (0); + f1 (1); + return 0; +} diff --git a/main/libgomp/testsuite/libgomp.c/depend-6.c b/main/libgomp/testsuite/libgomp.c/depend-6.c new file mode 100644 index 00000000000..d30e6e9dd90 --- /dev/null +++ b/main/libgomp/testsuite/libgomp.c/depend-6.c @@ -0,0 +1,3 @@ +/* { dg-set-target-env-var OMP_NUM_THREADS "1" } */ + +#include "depend-1.c" diff --git a/main/libgomp/testsuite/libgomp.c/depend-7.c b/main/libgomp/testsuite/libgomp.c/depend-7.c new file mode 100644 index 00000000000..bd4a3f9dec0 --- /dev/null +++ b/main/libgomp/testsuite/libgomp.c/depend-7.c @@ -0,0 +1,3 @@ +/* { dg-set-target-env-var OMP_NUM_THREADS "1" } */ + +#include "depend-2.c" diff --git a/main/libgomp/testsuite/libgomp.c/depend-8.c b/main/libgomp/testsuite/libgomp.c/depend-8.c new file mode 100644 index 00000000000..4dcce671c09 --- /dev/null +++ b/main/libgomp/testsuite/libgomp.c/depend-8.c @@ -0,0 +1,3 @@ +/* { dg-set-target-env-var OMP_NUM_THREADS "1" } */ + +#include "depend-3.c" diff --git a/main/libgomp/testsuite/libgomp.c/depend-9.c b/main/libgomp/testsuite/libgomp.c/depend-9.c new file mode 100644 index 00000000000..a52c47ac6db --- /dev/null +++ b/main/libgomp/testsuite/libgomp.c/depend-9.c @@ -0,0 +1,3 @@ +/* { dg-set-target-env-var OMP_NUM_THREADS "1" } */ + +#include "depend-4.c" diff --git a/main/libitm/ChangeLog b/main/libitm/ChangeLog index 17bb0a66448..ce1cc219ae2 100644 --- a/main/libitm/ChangeLog +++ b/main/libitm/ChangeLog @@ -1,3 +1,8 @@ +2014-07-24 Richard Henderson + + * config/aarch64/sjlj.S (_ITM_beginTransaction): Use post-inc + addressing mode in epilogue. + 2014-05-28 Rainer Orth * acinclude.m4 (LIBITM_CHECK_LINKER_HWCAP): Check for diff --git a/main/libitm/config/aarch64/sjlj.S b/main/libitm/config/aarch64/sjlj.S index 4207da96638..77118dd4744 100644 --- a/main/libitm/config/aarch64/sjlj.S +++ b/main/libitm/config/aarch64/sjlj.S @@ -53,8 +53,7 @@ _ITM_beginTransaction: bl GTM_begin_transaction /* Return; we don't need to restore any of the call-saved regs. */ - ldp x29, x30, [sp] - add sp, sp, #11*16 + ldp x29, x30, [sp], 11*16 cfi_adjust_cfa_offset(-11*16) cfi_restore(x29) cfi_restore(x30) diff --git a/main/libobjc/ChangeLog b/main/libobjc/ChangeLog index 2775444b062..6559fcce24c 100644 --- a/main/libobjc/ChangeLog +++ b/main/libobjc/ChangeLog @@ -1,3 +1,10 @@ +2014-07-27 Alan Modra + Matthias Klose + + PR libobjc/61920 + + * encoding.c: Define rs6000_special_adjust_field_align_p. + 2014-01-02 Richard Sandiford Update copyright years diff --git a/main/libobjc/encoding.c b/main/libobjc/encoding.c index 7ecc812a954..a603b8c3c7a 100644 --- a/main/libobjc/encoding.c +++ b/main/libobjc/encoding.c @@ -192,6 +192,7 @@ _darwin_rs6000_special_round_type_align (const char *struc, int comp, int spec) ? MAX (MAX (COMPUTED, SPECIFIED), 64) \ : MAX (COMPUTED, SPECIFIED));}) +#define rs6000_special_adjust_field_align_p(FIELD, COMPUTED) 0 /* Skip a variable name, enclosed in quotes ("). */ static inline diff --git a/main/libstdc++-v3/ChangeLog b/main/libstdc++-v3/ChangeLog index 3f2101be715..15422ae9713 100644 --- a/main/libstdc++-v3/ChangeLog +++ b/main/libstdc++-v3/ChangeLog @@ -1,3 +1,80 @@ +2014-08-02 Paolo Carlini + + PR c++/15339 + * testsuite/26_numerics/headers/complex/synopsis.cc: Fix. + +2014-08-01 Zifei Tong + + * libsupc++/atexit_thread.cc (HAVE___CXA_THREAD_ATEXIT_IMPL): Add + _GLIBCXX_ prefix to macro. + +2014-07-29 Jonathan Wakely + + * python/libstdcxx/v6/printers.py + (SingleObjContainerPrinter._contained): Use compatibility mixin. + +2014-07-29 François Dumont + + * testsuite/util/testsuite_allocator.h + (tracker_allocator_counter::allocate): Remove new invocation, only + collect information. + (tracker_allocator_counter::deallocate): Remove delete invocation, only + collect information. + (check_inconsistent_alloc_value_type): New. + (tracker_allocator): Transform as a facade for any allocator type. + (uneq_allocator): Likewise. + (propagating_allocator): Likewise. + * testsuite/23_containers/forward_list/debug/move_assign_neg.cc: Use an + explicitly non propagating allocator. + * testsuite/23_containers/map/debug/move_assign_neg.cc: Likewise. + * testsuite/23_containers/multimap/debug/move_assign_neg.cc: likewise. + * testsuite/23_containers/multiset/debug/move_assign_neg.cc: Likewise. + * testsuite/23_containers/set/debug/move_assign_neg.cc: Likewise. + * testsuite/23_containers/unordered_map/debug/move_assign_neg.cc: + Likewise. + * testsuite/23_containers/unordered_multimap/debug/move_assign_neg.cc: + Likewise. + * testsuite/23_containers/unordered_multiset/debug/move_assign_neg.cc: + Likewise. + * testsuite/23_containers/unordered_set/debug/move_assign_neg.cc: + Likewise. + * testsuite/23_containers/vector/debug/move_assign_neg.cc: Likewise. + +2014-07-29 Jonathan Wakely + + PR libstdc++/61946 + * include/ext/rope (rope::rope(char_producer<_CharT>*, size_t, bool, + const allocator_type&)): Pass non-const allocator to + _S_new_RopeFunction. + * testsuite/ext/rope/61946.cc: New. + + PR libstdc++/61947 + * include/std/tuple (_Head_base): Use allocator_arg_t parameters to + disambiguate unary constructors. + (_Tuple_impl): Pass allocator_arg_t arguments. + * testsuite/20_util/tuple/61947.cc: New. + * testsuite/20_util/uses_allocator/cons_neg.cc: Adjust dg-error line. + +2014-07-29 Ed Smith-Rowland <3dw4rd@verizon.net> + + PR libstdc++/60037 - SIGFPE in std::generate_canonical + * include/bits/random.h (_Adaptor): static_assert for non floating-point + result type. + * include/bits/random.tcc (generate_canonical): Ditto. + * include/ext/random.tcc (hypergeometric_distribution::operator()): + Use double as a rng result type. + * testsuite/26_numerics/random/pr60037-neg.cc: New. + * testsuite/ext/random/hypergeometric_distribution/pr60037.cc: New. + +2014-07-25 Uros Bizjak + + * config/abi/post/alpha-linux-gnu/baseline_symbols.txt: Update. + +2014-07-25 Ed Smith-Rowland <3dw4rd@verizon.net> + + * include/experimental/string_view: Make the literal operators + constexpr like the ctors they call. + 2014-07-23 H.J. Lu * config/abi/post/x86_64-linux-gnu/x32/baseline_symbols.txt: Update. diff --git a/main/libstdc++-v3/config/abi/post/alpha-linux-gnu/baseline_symbols.txt b/main/libstdc++-v3/config/abi/post/alpha-linux-gnu/baseline_symbols.txt index e518a0a2fb3..c3f9abe770b 100644 --- a/main/libstdc++-v3/config/abi/post/alpha-linux-gnu/baseline_symbols.txt +++ b/main/libstdc++-v3/config/abi/post/alpha-linux-gnu/baseline_symbols.txt @@ -1355,6 +1355,8 @@ FUNC:_ZNSt11range_errorC2ERKSs@@GLIBCXX_3.4 FUNC:_ZNSt11range_errorD0Ev@@GLIBCXX_3.4 FUNC:_ZNSt11range_errorD1Ev@@GLIBCXX_3.4 FUNC:_ZNSt11range_errorD2Ev@@GLIBCXX_3.4.15 +FUNC:_ZNSt11regex_errorC1ENSt15regex_constants10error_typeE@@GLIBCXX_3.4.20 +FUNC:_ZNSt11regex_errorC2ENSt15regex_constants10error_typeE@@GLIBCXX_3.4.21 FUNC:_ZNSt11regex_errorD0Ev@@GLIBCXX_3.4.15 FUNC:_ZNSt11regex_errorD1Ev@@GLIBCXX_3.4.15 FUNC:_ZNSt11regex_errorD2Ev@@GLIBCXX_3.4.15 @@ -2460,6 +2462,7 @@ FUNC:_ZSt21__throw_runtime_errorPKc@@GLIBCXX_3.4 FUNC:_ZSt22__throw_overflow_errorPKc@@GLIBCXX_3.4 FUNC:_ZSt23__throw_underflow_errorPKc@@GLIBCXX_3.4 FUNC:_ZSt24__throw_invalid_argumentPKc@@GLIBCXX_3.4 +FUNC:_ZSt24__throw_out_of_range_fmtPKcz@@GLIBCXX_3.4.20 FUNC:_ZSt25__throw_bad_function_callv@@GLIBCXX_3.4.14 FUNC:_ZSt28_Rb_tree_rebalance_for_erasePSt18_Rb_tree_node_baseRS_@@GLIBCXX_3.4 FUNC:_ZSt29_Rb_tree_insert_and_rebalancebPSt18_Rb_tree_node_baseS0_RS_@@GLIBCXX_3.4 @@ -2751,6 +2754,7 @@ OBJECT:0:CXXABI_1.3.5 OBJECT:0:CXXABI_1.3.6 OBJECT:0:CXXABI_1.3.7 OBJECT:0:CXXABI_1.3.8 +OBJECT:0:CXXABI_1.3.9 OBJECT:0:CXXABI_LDBL_1.3 OBJECT:0:CXXABI_TM_1 OBJECT:0:GLIBCXX_3.4 @@ -2767,6 +2771,7 @@ OBJECT:0:GLIBCXX_3.4.18 OBJECT:0:GLIBCXX_3.4.19 OBJECT:0:GLIBCXX_3.4.2 OBJECT:0:GLIBCXX_3.4.20 +OBJECT:0:GLIBCXX_3.4.21 OBJECT:0:GLIBCXX_3.4.3 OBJECT:0:GLIBCXX_3.4.4 OBJECT:0:GLIBCXX_3.4.5 @@ -3391,6 +3396,8 @@ OBJECT:2:_ZTSi@@CXXABI_1.3 OBJECT:2:_ZTSj@@CXXABI_1.3 OBJECT:2:_ZTSl@@CXXABI_1.3 OBJECT:2:_ZTSm@@CXXABI_1.3 +OBJECT:2:_ZTSn@@CXXABI_1.3.9 +OBJECT:2:_ZTSo@@CXXABI_1.3.9 OBJECT:2:_ZTSs@@CXXABI_1.3 OBJECT:2:_ZTSt@@CXXABI_1.3 OBJECT:2:_ZTSv@@CXXABI_1.3 @@ -3498,6 +3505,8 @@ OBJECT:3:_ZTSPi@@CXXABI_1.3 OBJECT:3:_ZTSPj@@CXXABI_1.3 OBJECT:3:_ZTSPl@@CXXABI_1.3 OBJECT:3:_ZTSPm@@CXXABI_1.3 +OBJECT:3:_ZTSPn@@CXXABI_1.3.9 +OBJECT:3:_ZTSPo@@CXXABI_1.3.9 OBJECT:3:_ZTSPs@@CXXABI_1.3 OBJECT:3:_ZTSPt@@CXXABI_1.3 OBJECT:3:_ZTSPv@@CXXABI_1.3 @@ -3835,6 +3844,8 @@ OBJECT:4:_ZTSPKi@@CXXABI_1.3 OBJECT:4:_ZTSPKj@@CXXABI_1.3 OBJECT:4:_ZTSPKl@@CXXABI_1.3 OBJECT:4:_ZTSPKm@@CXXABI_1.3 +OBJECT:4:_ZTSPKn@@CXXABI_1.3.9 +OBJECT:4:_ZTSPKo@@CXXABI_1.3.9 OBJECT:4:_ZTSPKs@@CXXABI_1.3 OBJECT:4:_ZTSPKt@@CXXABI_1.3 OBJECT:4:_ZTSPKv@@CXXABI_1.3 diff --git a/main/libstdc++-v3/include/bits/random.h b/main/libstdc++-v3/include/bits/random.h index a466a45ba4d..774f726d0a6 100644 --- a/main/libstdc++-v3/include/bits/random.h +++ b/main/libstdc++-v3/include/bits/random.h @@ -164,6 +164,8 @@ _GLIBCXX_END_NAMESPACE_VERSION template struct _Adaptor { + static_assert(std::is_floating_point<_DInputType>::value, + "template argument not a floating point type"); public: _Adaptor(_Engine& __g) diff --git a/main/libstdc++-v3/include/bits/random.tcc b/main/libstdc++-v3/include/bits/random.tcc index 0eda287f481..8849ee90d64 100644 --- a/main/libstdc++-v3/include/bits/random.tcc +++ b/main/libstdc++-v3/include/bits/random.tcc @@ -3463,6 +3463,9 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION _RealType generate_canonical(_UniformRandomNumberGenerator& __urng) { + static_assert(std::is_floating_point<_RealType>::value, + "template argument not a floating point type"); + const size_t __b = std::min(static_cast(std::numeric_limits<_RealType>::digits), __bits); diff --git a/main/libstdc++-v3/include/experimental/string_view b/main/libstdc++-v3/include/experimental/string_view index 4b1a10789c3..041f7489deb 100644 --- a/main/libstdc++-v3/include/experimental/string_view +++ b/main/libstdc++-v3/include/experimental/string_view @@ -664,22 +664,22 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION inline namespace string_view_literals { - inline basic_string_view + inline constexpr basic_string_view operator""sv(const char* __str, size_t __len) { return basic_string_view{__str, __len}; } #ifdef _GLIBCXX_USE_WCHAR_T - inline basic_string_view + inline constexpr basic_string_view operator""sv(const wchar_t* __str, size_t __len) { return basic_string_view{__str, __len}; } #endif #ifdef _GLIBCXX_USE_C99_STDINT_TR1 - inline basic_string_view + inline constexpr basic_string_view operator""sv(const char16_t* __str, size_t __len) { return basic_string_view{__str, __len}; } - inline basic_string_view + inline constexpr basic_string_view operator""sv(const char32_t* __str, size_t __len) { return basic_string_view{__str, __len}; } #endif diff --git a/main/libstdc++-v3/include/ext/random.tcc b/main/libstdc++-v3/include/ext/random.tcc index 432865cb548..05361d8f491 100644 --- a/main/libstdc++-v3/include/ext/random.tcc +++ b/main/libstdc++-v3/include/ext/random.tcc @@ -1355,7 +1355,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION operator()(_UniformRandomNumberGenerator& __urng, const param_type& __param) { - std::__detail::_Adaptor<_UniformRandomNumberGenerator, result_type> + std::__detail::_Adaptor<_UniformRandomNumberGenerator, double> __aurng(__urng); result_type __a = __param.successful_size(); diff --git a/main/libstdc++-v3/include/ext/rope b/main/libstdc++-v3/include/ext/rope index df3d4bb3179..147b335a8b8 100644 --- a/main/libstdc++-v3/include/ext/rope +++ b/main/libstdc++-v3/include/ext/rope @@ -1544,7 +1544,7 @@ protected: typedef typename _Base::allocator_type allocator_type; using _Base::_M_tree_ptr; using _Base::get_allocator; - using _Base::_M_get_allocator; + using _Base::_M_get_allocator; typedef __GC_CONST _CharT* _Cstrptr; static _CharT _S_empty_c_str[1]; @@ -1876,8 +1876,9 @@ protected: const allocator_type& __a = allocator_type()) : _Base(__a) { - this->_M_tree_ptr = (0 == __len) ? - 0 : _S_new_RopeFunction(__fn, __len, __delete_fn, __a); + this->_M_tree_ptr = (0 == __len) + ? 0 + : _S_new_RopeFunction(__fn, __len, __delete_fn, _M_get_allocator()); } rope(const rope& __x, const allocator_type& __a = allocator_type()) diff --git a/main/libstdc++-v3/include/std/tuple b/main/libstdc++-v3/include/std/tuple index ef8aa5ab6f4..6c1032fb46c 100644 --- a/main/libstdc++-v3/include/std/tuple +++ b/main/libstdc++-v3/include/std/tuple @@ -61,21 +61,22 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION constexpr _Head_base(const _Head& __h) : _Head(__h) { } - template::value>::type> + constexpr _Head_base(const _Head_base&) = default; + constexpr _Head_base(_Head_base&&) = default; + + template constexpr _Head_base(_UHead&& __h) : _Head(std::forward<_UHead>(__h)) { } - _Head_base(__uses_alloc0) + _Head_base(allocator_arg_t, __uses_alloc0) : _Head() { } template - _Head_base(__uses_alloc1<_Alloc> __a) + _Head_base(allocator_arg_t, __uses_alloc1<_Alloc> __a) : _Head(allocator_arg, *__a._M_a) { } template - _Head_base(__uses_alloc2<_Alloc> __a) + _Head_base(allocator_arg_t, __uses_alloc2<_Alloc> __a) : _Head(*__a._M_a) { } template @@ -106,21 +107,22 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION constexpr _Head_base(const _Head& __h) : _M_head_impl(__h) { } - template::value>::type> + constexpr _Head_base(const _Head_base&) = default; + constexpr _Head_base(_Head_base&&) = default; + + template constexpr _Head_base(_UHead&& __h) : _M_head_impl(std::forward<_UHead>(__h)) { } - _Head_base(__uses_alloc0) + _Head_base(allocator_arg_t, __uses_alloc0) : _M_head_impl() { } template - _Head_base(__uses_alloc1<_Alloc> __a) + _Head_base(allocator_arg_t, __uses_alloc1<_Alloc> __a) : _M_head_impl(allocator_arg, *__a._M_a) { } template - _Head_base(__uses_alloc2<_Alloc> __a) + _Head_base(allocator_arg_t, __uses_alloc2<_Alloc> __a) : _M_head_impl(*__a._M_a) { } template @@ -258,7 +260,7 @@ _GLIBCXX_BEGIN_NAMESPACE_VERSION template _Tuple_impl(allocator_arg_t __tag, const _Alloc& __a) : _Inherited(__tag, __a), - _Base(__use_alloc<_Head>(__a)) { } + _Base(__tag, __use_alloc<_Head>(__a)) { } template _Tuple_impl(allocator_arg_t __tag, const _Alloc& __a, diff --git a/main/libstdc++-v3/libsupc++/atexit_thread.cc b/main/libstdc++-v3/libsupc++/atexit_thread.cc index db202000231..dff08e92477 100644 --- a/main/libstdc++-v3/libsupc++/atexit_thread.cc +++ b/main/libstdc++-v3/libsupc++/atexit_thread.cc @@ -26,7 +26,7 @@ #include #include "bits/gthr.h" -#if HAVE___CXA_THREAD_ATEXIT_IMPL +#if _GLIBCXX_HAVE___CXA_THREAD_ATEXIT_IMPL extern "C" int __cxa_thread_atexit_impl (void (*func) (void *), void *arg, void *d); @@ -38,7 +38,7 @@ __cxxabiv1::__cxa_thread_atexit (void (*dtor)(void *), return __cxa_thread_atexit_impl (dtor, obj, dso_handle); } -#else /* HAVE___CXA_THREAD_ATEXIT_IMPL */ +#else /* _GLIBCXX_HAVE___CXA_THREAD_ATEXIT_IMPL */ namespace { // One element in a singly-linked stack of cleanups. @@ -142,4 +142,4 @@ __cxxabiv1::__cxa_thread_atexit (void (*dtor)(void *), void *obj, void */*dso_ha return 0; } -#endif /* HAVE___CXA_THREAD_ATEXIT_IMPL */ +#endif /* _GLIBCXX_HAVE___CXA_THREAD_ATEXIT_IMPL */ diff --git a/main/libstdc++-v3/python/libstdcxx/v6/printers.py b/main/libstdc++-v3/python/libstdcxx/v6/printers.py index 15d7a88dbf8..2e5cd6ca0a8 100644 --- a/main/libstdc++-v3/python/libstdcxx/v6/printers.py +++ b/main/libstdc++-v3/python/libstdcxx/v6/printers.py @@ -851,14 +851,14 @@ class SingleObjContainerPrinter(object): return gdb.types.apply_type_recognizers(gdb.types.get_type_recognizers(), type) or str(type) - class _contained: + class _contained(Iterator): def __init__ (self, val): self.val = val def __iter__ (self): return self - def next (self): + def __next__(self): if self.val is None: raise StopIteration retval = self.val diff --git a/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/20_util/tuple/61947.cc similarity index 60% copy from main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc copy to main/libstdc++-v3/testsuite/20_util/tuple/61947.cc index b7f51efd393..7e77de657a1 100644 --- a/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/20_util/tuple/61947.cc @@ -1,3 +1,6 @@ +// { dg-options "-std=gnu++11" } +// { dg-do compile } + // Copyright (C) 2014 Free Software Foundation, Inc. // // This file is part of the GNU ISO C++ Library. This library is free @@ -5,43 +8,22 @@ // 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 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. -// + // You should have received a copy of the GNU General Public License along // with this library; see the file COPYING3. If not see // . -// -// { dg-options "-std=gnu++11" } -// { dg-do run { xfail *-*-* } } - -#include -#include - -void test01() -{ - bool test __attribute__((unused)) = true; - - typedef __gnu_test::uneq_allocator alloc_type; - typedef __gnu_debug::set, alloc_type> test_type; - test_type v1(alloc_type(1)); - v1.insert(0); - auto it = v1.begin(); +#include - test_type v2(alloc_type(2)); - v2.insert(1); - - v2 = std::move(v1); - - VERIFY( it == v2.begin() ); // Error, it is singular. -} +struct ConvertibleToAny { + template operator T() const { return T(); } +}; -int main() -{ - test01(); - return 0; +int main() { + std::tuple t(ConvertibleToAny{}); } diff --git a/main/libstdc++-v3/testsuite/20_util/uses_allocator/cons_neg.cc b/main/libstdc++-v3/testsuite/20_util/uses_allocator/cons_neg.cc index cf5d6a57dd9..6396e2678ec 100644 --- a/main/libstdc++-v3/testsuite/20_util/uses_allocator/cons_neg.cc +++ b/main/libstdc++-v3/testsuite/20_util/uses_allocator/cons_neg.cc @@ -44,4 +44,4 @@ void test01() tuple t(allocator_arg, a, 1); } -// { dg-error "no matching function" "" { target *-*-* } 91 } +// { dg-error "no matching function" "" { target *-*-* } 92 } diff --git a/main/libstdc++-v3/testsuite/23_containers/forward_list/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/forward_list/debug/move_assign_neg.cc index 91e459fd3c3..934afbedd6b 100644 --- a/main/libstdc++-v3/testsuite/23_containers/forward_list/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/forward_list/debug/move_assign_neg.cc @@ -25,7 +25,7 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator alloc_type; + typedef __gnu_test::propagating_allocator alloc_type; typedef __gnu_debug::forward_list test_type; test_type v1(alloc_type(1)); diff --git a/main/libstdc++-v3/testsuite/23_containers/map/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/map/debug/move_assign_neg.cc index 0d63fe944bf..3f2a7ca532b 100644 --- a/main/libstdc++-v3/testsuite/23_containers/map/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/map/debug/move_assign_neg.cc @@ -25,7 +25,8 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator > alloc_type; + typedef __gnu_test::propagating_allocator, + false> alloc_type; typedef __gnu_debug::map, alloc_type> test_type; test_type v1(alloc_type(1)); diff --git a/main/libstdc++-v3/testsuite/23_containers/multimap/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/multimap/debug/move_assign_neg.cc index e514a28dbed..da2950fe458 100644 --- a/main/libstdc++-v3/testsuite/23_containers/multimap/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/multimap/debug/move_assign_neg.cc @@ -25,7 +25,8 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator > alloc_type; + typedef __gnu_test::propagating_allocator, + false> alloc_type; typedef __gnu_debug::multimap, alloc_type> test_type; test_type v1(alloc_type(1)); diff --git a/main/libstdc++-v3/testsuite/23_containers/multiset/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/multiset/debug/move_assign_neg.cc index af879d94dad..6f5f5b430cc 100644 --- a/main/libstdc++-v3/testsuite/23_containers/multiset/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/multiset/debug/move_assign_neg.cc @@ -25,7 +25,7 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator alloc_type; + typedef __gnu_test::propagating_allocator alloc_type; typedef __gnu_debug::multiset, alloc_type> test_type; test_type v1(alloc_type(1)); diff --git a/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc index b7f51efd393..b491a03276d 100644 --- a/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc @@ -25,7 +25,7 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator alloc_type; + typedef __gnu_test::propagating_allocator alloc_type; typedef __gnu_debug::set, alloc_type> test_type; test_type v1(alloc_type(1)); diff --git a/main/libstdc++-v3/testsuite/23_containers/unordered_map/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/unordered_map/debug/move_assign_neg.cc index ef5db1165f3..3670f73b0d3 100644 --- a/main/libstdc++-v3/testsuite/23_containers/unordered_map/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/unordered_map/debug/move_assign_neg.cc @@ -25,7 +25,8 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator > alloc_type; + typedef __gnu_test::propagating_allocator, + false> alloc_type; typedef __gnu_debug::unordered_map, std::equal_to, alloc_type> test_type; diff --git a/main/libstdc++-v3/testsuite/23_containers/unordered_multimap/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/unordered_multimap/debug/move_assign_neg.cc index b6de1eef581..7a8fa77c4d8 100644 --- a/main/libstdc++-v3/testsuite/23_containers/unordered_multimap/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/unordered_multimap/debug/move_assign_neg.cc @@ -25,7 +25,8 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator> alloc_type; + typedef __gnu_test::propagating_allocator, + false> alloc_type; typedef __gnu_debug::unordered_multimap, std::equal_to, alloc_type> test_type; diff --git a/main/libstdc++-v3/testsuite/23_containers/unordered_multiset/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/unordered_multiset/debug/move_assign_neg.cc index 52a8df2a9f2..9fe72e1f254 100644 --- a/main/libstdc++-v3/testsuite/23_containers/unordered_multiset/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/unordered_multiset/debug/move_assign_neg.cc @@ -25,7 +25,7 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator alloc_type; + typedef __gnu_test::propagating_allocator alloc_type; typedef __gnu_debug::unordered_multiset, std::equal_to, alloc_type> test_type; diff --git a/main/libstdc++-v3/testsuite/23_containers/unordered_set/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/unordered_set/debug/move_assign_neg.cc index 9d2a8abc425..b1b71e118ff 100644 --- a/main/libstdc++-v3/testsuite/23_containers/unordered_set/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/unordered_set/debug/move_assign_neg.cc @@ -25,7 +25,7 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator alloc_type; + typedef __gnu_test::propagating_allocator alloc_type; typedef __gnu_debug::unordered_set, std::equal_to, alloc_type> test_type; diff --git a/main/libstdc++-v3/testsuite/23_containers/vector/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/23_containers/vector/debug/move_assign_neg.cc index eb2233b35fe..3de0723195e 100644 --- a/main/libstdc++-v3/testsuite/23_containers/vector/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/23_containers/vector/debug/move_assign_neg.cc @@ -27,7 +27,7 @@ void test01() { bool test __attribute__((unused)) = true; - typedef __gnu_test::uneq_allocator alloc_type; + typedef __gnu_test::propagating_allocator alloc_type; typedef __gnu_debug::vector test_type; test_type v1(alloc_type(1)); diff --git a/main/libstdc++-v3/testsuite/26_numerics/headers/complex/synopsis.cc b/main/libstdc++-v3/testsuite/26_numerics/headers/complex/synopsis.cc index 64b5b2e5eb1..4f08c78e7cc 100644 --- a/main/libstdc++-v3/testsuite/26_numerics/headers/complex/synopsis.cc +++ b/main/libstdc++-v3/testsuite/26_numerics/headers/complex/synopsis.cc @@ -72,7 +72,7 @@ namespace std { template T arg(const complex&); template T norm(const complex&); template complex conj(const complex&); - template complex polar(const T& rho, const T& theta = 0); + template complex polar(const T& rho, const T& theta); // 26.2.8 transcendentals: template complex cos(const complex&); diff --git a/main/libstdc++-v3/testsuite/26_numerics/random/pr60037-neg.cc b/main/libstdc++-v3/testsuite/26_numerics/random/pr60037-neg.cc new file mode 100644 index 00000000000..11d553910c9 --- /dev/null +++ b/main/libstdc++-v3/testsuite/26_numerics/random/pr60037-neg.cc @@ -0,0 +1,15 @@ +// { dg-do compile } +// { dg-options "-std=gnu++11" } + +#include + +std::mt19937 urng; + +std::__detail::_Adaptor aurng(urng); + +auto x = std::generate_canonical::digits>(urng); + +// { dg-error "static assertion failed: template argument not a floating point type" "" { target *-*-* } 167 } + +// { dg-error "static assertion failed: template argument not a floating point type" "" { target *-*-* } 3466 } diff --git a/main/libstdc++-v3/testsuite/ext/random/hypergeometric_distribution/pr60037.cc b/main/libstdc++-v3/testsuite/ext/random/hypergeometric_distribution/pr60037.cc new file mode 100644 index 00000000000..d3088a6ec38 --- /dev/null +++ b/main/libstdc++-v3/testsuite/ext/random/hypergeometric_distribution/pr60037.cc @@ -0,0 +1,23 @@ +// { dg-options "-std=gnu++11 -O0" } +// { dg-require-cstdint "" } +// { dg-require-cmath "" } + +#include +#include + +void +hyperplot(unsigned int N, unsigned int K, unsigned int n) +{ + std::mt19937 re; // the default engine + __gnu_cxx::hypergeometric_distribution<> hd(N, K, n); + auto gen = std::bind(hd, re); + gen(); +} + +int +main() +{ + hyperplot(15, 3, 2); + hyperplot(500, 50, 30); + hyperplot(100, 20, 5); +} diff --git a/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc b/main/libstdc++-v3/testsuite/ext/rope/61946.cc similarity index 58% copy from main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc copy to main/libstdc++-v3/testsuite/ext/rope/61946.cc index b7f51efd393..ba73b485667 100644 --- a/main/libstdc++-v3/testsuite/23_containers/set/debug/move_assign_neg.cc +++ b/main/libstdc++-v3/testsuite/ext/rope/61946.cc @@ -5,43 +5,27 @@ // 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 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the // GNU General Public License for more details. -// + // You should have received a copy of the GNU General Public License along // with this library; see the file COPYING3. If not see // . -// -// { dg-options "-std=gnu++11" } -// { dg-do run { xfail *-*-* } } - -#include -#include -void test01() -{ - bool test __attribute__((unused)) = true; - - typedef __gnu_test::uneq_allocator alloc_type; - typedef __gnu_debug::set, alloc_type> test_type; - - test_type v1(alloc_type(1)); - v1.insert(0); - auto it = v1.begin(); +// { dg-do compile } - test_type v2(alloc_type(2)); - v2.insert(1); +#include - v2 = std::move(v1); - - VERIFY( it == v2.begin() ); // Error, it is singular. -} +struct empty_char_prod : __gnu_cxx::char_producer +{ + virtual void operator()(size_t, size_t, char*) {} +}; -int main() +int main () { - test01(); - return 0; + empty_char_prod* ecp = new empty_char_prod; + __gnu_cxx::crope excrope( ecp, 10L, true ); } diff --git a/main/libstdc++-v3/testsuite/util/testsuite_allocator.h b/main/libstdc++-v3/testsuite/util/testsuite_allocator.h index 822a025f4fa..8edc0a5ad78 100644 --- a/main/libstdc++-v3/testsuite/util/testsuite_allocator.h +++ b/main/libstdc++-v3/testsuite/util/testsuite_allocator.h @@ -29,6 +29,7 @@ #include #include #include +#include #include namespace __gnu_test @@ -38,26 +39,19 @@ namespace __gnu_test public: typedef std::size_t size_type; - static void* + static void allocate(size_type blocksize) - { - void* p = ::operator new(blocksize); - allocationCount_ += blocksize; - return p; - } + { allocationCount_ += blocksize; } static void - construct() { constructCount_++; } + construct() { ++constructCount_; } static void - destroy() { destructCount_++; } + destroy() { ++destructCount_; } static void - deallocate(void* p, size_type blocksize) - { - ::operator delete(p); - deallocationCount_ += blocksize; - } + deallocate(size_type blocksize) + { deallocationCount_ += blocksize; } static size_type get_allocation_count() { return allocationCount_; } @@ -87,103 +81,142 @@ namespace __gnu_test static int destructCount_; }; - // A simple basic allocator that just forwards to the - // tracker_allocator_counter to fulfill memory requests. This class - // is templated on the target object type, but tracker isn't. - template - class tracker_allocator - { - private: - typedef tracker_allocator_counter counter_type; - - public: - typedef T value_type; - typedef T* pointer; - typedef const T* const_pointer; - typedef T& reference; - typedef const T& const_reference; - typedef std::size_t size_type; - typedef std::ptrdiff_t difference_type; - - template struct rebind { typedef tracker_allocator other; }; - - pointer - address(reference value) const _GLIBCXX_NOEXCEPT - { return std::__addressof(value); } + // Helper to detect inconsistency between type used to instantiate an + // allocator and the underlying allocator value_type. + template + struct check_consistent_alloc_value_type; + + template + struct check_consistent_alloc_value_type + { typedef T value_type; }; + + // An allocator facade that intercepts allocate/deallocate/construct/destroy + // calls and track them through the tracker_allocator_counter class. This + // class is templated on the target object type, but tracker isn't. + template > + class tracker_allocator : public Alloc + { + private: + typedef tracker_allocator_counter counter_type; - const_pointer - address(const_reference value) const _GLIBCXX_NOEXCEPT - { return std::__addressof(value); } + typedef __gnu_cxx::__alloc_traits AllocTraits; - tracker_allocator() _GLIBCXX_USE_NOEXCEPT - { } + public: + typedef typename + check_consistent_alloc_value_type::value_type value_type; + typedef typename AllocTraits::pointer pointer; + typedef typename AllocTraits::size_type size_type; - tracker_allocator(const tracker_allocator&) _GLIBCXX_USE_NOEXCEPT - { } + template + struct rebind + { + typedef tracker_allocator::other> other; + }; + +#if __cplusplus >= 201103L + tracker_allocator() = default; + tracker_allocator(const tracker_allocator&) = default; + tracker_allocator(tracker_allocator&&) = default; + + // Perfect forwarding constructor. + template + tracker_allocator(_Args&&... __args) + : Alloc(std::forward<_Args>(__args)...) + { } +#else + tracker_allocator() + { } - template - tracker_allocator(const tracker_allocator&) _GLIBCXX_USE_NOEXCEPT + tracker_allocator(const tracker_allocator&) { } - ~tracker_allocator() _GLIBCXX_USE_NOEXCEPT - { } + ~tracker_allocator() + { } +#endif - size_type - max_size() const _GLIBCXX_USE_NOEXCEPT - { return size_type(-1) / sizeof(T); } + template + tracker_allocator(const tracker_allocator::other>& alloc) + _GLIBCXX_USE_NOEXCEPT + : Alloc(alloc) + { } - pointer - allocate(size_type n, const void* = 0) - { return static_cast(counter_type::allocate(n * sizeof(T))); } + pointer + allocate(size_type n, const void* = 0) + { + pointer p = AllocTraits::allocate(*this, n); + counter_type::allocate(n * sizeof(T)); + return p; + } #if __cplusplus >= 201103L - template + template + void + construct(U* p, Args&&... args) + { + AllocTraits::construct(*this, p, std::forward(args)...); + counter_type::construct(); + } + + template + void + destroy(U* p) + { + AllocTraits::destroy(*this, p); + counter_type::destroy(); + } +#else void - construct(U* p, Args&&... args) + construct(pointer p, const T& value) { - ::new((void *)p) U(std::forward(args)...); + AllocTraits::construct(*this, p, value); counter_type::construct(); } - template void - destroy(U* p) + destroy(pointer p) { - p->~U(); + AllocTraits::destroy(*this, p); counter_type::destroy(); } -#else - void - construct(pointer p, const T& value) - { - ::new ((void *)p) T(value); - counter_type::construct(); - } - - void - destroy(pointer p) - { - p->~T(); - counter_type::destroy(); - } #endif - void - deallocate(pointer p, size_type num) - { counter_type::deallocate(p, num * sizeof(T)); } - }; + void + deallocate(pointer p, size_type num) + { + counter_type::deallocate(num * sizeof(T)); + AllocTraits::deallocate(*this, p, num); + } + + // Implement swap for underlying allocators that might need it. + friend inline void + swap(tracker_allocator& a, tracker_allocator& b) + { + using std::swap; - template + Alloc& aa = a; + Alloc& ab = b; + swap(aa, ab); + } + }; + + template bool - operator==(const tracker_allocator&, - const tracker_allocator&) throw() - { return true; } + operator==(const tracker_allocator& lhs, + const tracker_allocator& rhs) throw() + { + const Alloc1& alloc1 = lhs; + const Alloc2& alloc2 = rhs; + return lhs == rhs; + } - template + template bool - operator!=(const tracker_allocator&, - const tracker_allocator&) throw() - { return false; } + operator!=(const tracker_allocator& lhs, + const tracker_allocator& rhs) throw() + { return !(lhs == rhs); } bool check_construct_destroy(const char* tag, int expected_c, int expected_d); @@ -193,7 +226,7 @@ namespace __gnu_test check_deallocate_null() { // Let's not core here... - Alloc a; + Alloc a; a.deallocate(0, 1); a.deallocate(0, 10); return true; @@ -219,7 +252,6 @@ namespace __gnu_test throw; } - // A simple allocator which can be constructed endowed of a given // "personality" (an integer), queried in operator== to simulate the // behavior of realworld "unequal" allocators (i.e., not exploiting @@ -227,7 +259,7 @@ namespace __gnu_test // filled at allocation time with (pointer, personality) pairs, is // then consulted to enforce the requirements in Table 32 about // deallocation vs allocator equality. Note that this allocator is - // swappable, not assignable, consistently with Option 3 of DR 431 + // swappable, not copy assignable, consistently with Option 3 of DR 431 // (see N1599). struct uneq_allocator_base { @@ -244,35 +276,49 @@ namespace __gnu_test } }; - template + template > class uneq_allocator - : private uneq_allocator_base + : private uneq_allocator_base, + public Alloc { + typedef __gnu_cxx::__alloc_traits AllocTraits; + + Alloc& base() { return *this; } + const Alloc& base() const { return *this; } + void swap_base(Alloc& b) { swap(b, this->base()); } + public: - typedef std::size_t size_type; - typedef std::ptrdiff_t difference_type; - typedef Tp* pointer; - typedef const Tp* const_pointer; - typedef Tp& reference; - typedef const Tp& const_reference; - typedef Tp value_type; + typedef typename check_consistent_alloc_value_type::value_type + value_type; + typedef typename AllocTraits::size_type size_type; + typedef typename AllocTraits::pointer pointer; #if __cplusplus >= 201103L - typedef std::true_type propagate_on_container_swap; + typedef std::true_type propagate_on_container_swap; #endif template - struct rebind - { typedef uneq_allocator other; }; + struct rebind + { + typedef uneq_allocator::other> other; + }; uneq_allocator() _GLIBCXX_USE_NOEXCEPT : personality(0) { } uneq_allocator(int person) _GLIBCXX_USE_NOEXCEPT : personality(person) { } + +#if __cplusplus >= 201103L + uneq_allocator(const uneq_allocator&) = default; + uneq_allocator(uneq_allocator&&) = default; +#endif template - uneq_allocator(const uneq_allocator& b) _GLIBCXX_USE_NOEXCEPT + uneq_allocator(const uneq_allocator::other>& b) + _GLIBCXX_USE_NOEXCEPT : personality(b.get_personality()) { } ~uneq_allocator() _GLIBCXX_USE_NOEXCEPT @@ -281,20 +327,10 @@ namespace __gnu_test int get_personality() const { return personality; } pointer - address(reference x) const _GLIBCXX_NOEXCEPT - { return std::__addressof(x); } - - const_pointer - address(const_reference x) const _GLIBCXX_NOEXCEPT - { return std::__addressof(x); } - - pointer - allocate(size_type n, const void* = 0) + allocate(size_type n, const void* hint = 0) { - if (__builtin_expect(n > this->max_size(), false)) - std::__throw_bad_alloc(); - - pointer p = static_cast(::operator new(n * sizeof(Tp))); + pointer p = AllocTraits::allocate(*this, n); + try { get_map().insert(map_type::value_type(reinterpret_cast(p), @@ -302,14 +338,15 @@ namespace __gnu_test } catch(...) { - ::operator delete(p); + AllocTraits::deallocate(*this, p, n); __throw_exception_again; } + return p; } void - deallocate(pointer p, size_type) + deallocate(pointer p, size_type n) { bool test __attribute__((unused)) = true; @@ -323,34 +360,18 @@ namespace __gnu_test VERIFY( it->second == personality ); get_map().erase(it); - ::operator delete(p); + AllocTraits::deallocate(*this, p, n); } - size_type - max_size() const _GLIBCXX_USE_NOEXCEPT - { return size_type(-1) / sizeof(Tp); } - #if __cplusplus >= 201103L - template - void - construct(U* p, Args&&... args) - { ::new((void *)p) U(std::forward(args)...); } - - template - void - destroy(U* p) { p->~U(); } - // Not copy assignable... uneq_allocator& operator=(const uneq_allocator&) = delete; -#else - void - construct(pointer p, const Tp& val) - { ::new((void *)p) Tp(val); } - - void - destroy(pointer p) { p->~Tp(); } + // ... but still moveable if base allocator is. + uneq_allocator& + operator=(uneq_allocator&&) = default; +#else private: // Not assignable... uneq_allocator& @@ -358,31 +379,39 @@ namespace __gnu_test #endif private: - // ... yet swappable! friend inline void swap(uneq_allocator& a, uneq_allocator& b) - { std::swap(a.personality, b.personality); } - + { + std::swap(a.personality, b.personality); + a.swap_base(b); + } + template - friend inline bool - operator==(const uneq_allocator& a, const uneq_allocator& b) - { return a.personality == b.personality; } + friend inline bool + operator==(const uneq_allocator& a, + const uneq_allocator::other>& b) + { return a.personality == b.personality; } template - friend inline bool - operator!=(const uneq_allocator& a, const uneq_allocator& b) - { return !(a == b); } + friend inline bool + operator!=(const uneq_allocator& a, + const uneq_allocator::other>& b) + { return !(a == b); } int personality; }; #if __cplusplus >= 201103L // An uneq_allocator which can be used to test allocator propagation. - template - class propagating_allocator : public uneq_allocator + template> + class propagating_allocator : public uneq_allocator { - typedef uneq_allocator base_alloc; + typedef __gnu_cxx::__alloc_traits AllocTraits; + + typedef uneq_allocator base_alloc; base_alloc& base() { return *this; } const base_alloc& base() const { return *this; } void swap_base(base_alloc& b) { swap(b, this->base()); } @@ -393,15 +422,20 @@ namespace __gnu_test // default allocator_traits::rebind_alloc would select // uneq_allocator::rebind so we must define rebind here template - struct rebind { typedef propagating_allocator other; }; + struct rebind + { + typedef propagating_allocator::other> other; + }; propagating_allocator(int i) noexcept : base_alloc(i) { } template - propagating_allocator(const propagating_allocator& a) - noexcept + propagating_allocator(const propagating_allocator::other>& a) + noexcept : base_alloc(a) { } @@ -418,8 +452,8 @@ namespace __gnu_test } template - propagating_allocator& - operator=(const propagating_allocator& a) noexcept + propagating_allocator& + operator=(const propagating_allocator& a) noexcept { static_assert(P2, "assigning propagating_allocator"); propagating_allocator(a).swap_base(*this); diff --git a/main/maintainer-scripts/ChangeLog b/main/maintainer-scripts/ChangeLog index f1915c23078..00772d87009 100644 --- a/main/maintainer-scripts/ChangeLog +++ b/main/maintainer-scripts/ChangeLog @@ -1,3 +1,7 @@ +2014-08-01 Arnaud Charlet + + * update_web_docs_svn: Simplify build of gnat_ugn. + 2014-06-12 Richard Biener * crontab: Remove 4.7 snapshot entry. diff --git a/main/maintainer-scripts/update_web_docs_svn b/main/maintainer-scripts/update_web_docs_svn index 8a5883eeca7..c66122068bf 100755 --- a/main/maintainer-scripts/update_web_docs_svn +++ b/main/maintainer-scripts/update_web_docs_svn @@ -20,11 +20,7 @@ MANUALS="cpp gcj gfortran gfc-internals - gnat_ug_unx - gnat_ug_vms - gnat_ug_vxw - gnat_ug_wnt - gnat_ugn_unw + gnat_ugn gnat-style gnat_rm libgomp @@ -118,8 +114,6 @@ fi find gcc -type f \( -name '*.texi' \ -o -path gcc/gcc/doc/install.texi2html \ -o -path gcc/gcc/doc/include/texinfo.tex \ - -o -path gcc/gcc/ada/xgnatugn.adb \ - -o -path gcc/gcc/ada/ug_words \ -o -path gcc/gcc/BASE-VER \ -o -path gcc/gcc/DEV-PHASE \ -o -print0 \) | xargs -0 rm -f @@ -131,14 +125,6 @@ tar cf docs-sources.tar gcc # and fdl.texi. includedir=gcc/gcc/doc/include -# Generate gnat_ugn_unw - -if [ -f gcc/gcc/ada/xgnatugn.adb ]; then - gnatmake -q gcc/gcc/ada/xgnatugn - ./xgnatugn unw gcc/gcc/ada/gnat_ugn.texi \ - gcc/gcc/ada/ug_words gnat_ugn_unw.texi -fi - # Generate gcc-vers.texi. ( echo "@set version-GCC $(cat gcc/gcc/BASE-VER)" @@ -161,7 +147,7 @@ for file in $MANUALS; do filename=`find . -name ${file}.texi` if [ "${filename}" ]; then includes="-I ${includedir} -I `dirname ${filename}`" - if [ "$file" = "gnat_ugn_unw" ]; then + if [ "$file" = "gnat_ugn" ]; then includes="$includes -I gcc/gcc/ada" fi makeinfo --html $includes -o ${file} ${filename} -- 2.11.4.GIT