diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2003-10-21 13:42:24 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2003-10-21 13:42:24 +0000 |
| commit | 9dfe12ae5b94d03c997ea2903022a5d2d5c5f266 (patch) | |
| tree | bdfc70477b60f1220cb05dd233a4570dd9c6bb5c /gcc/ada/sem_prag.adb | |
| parent | 1c662558a1113238a624245a45382d3df90ccf13 (diff) | |
| download | gcc-9dfe12ae5b94d03c997ea2903022a5d2d5c5f266.tar.gz | |
2003-10-21 Arnaud Charlet <charlet@act-europe.fr>
* 3psoccon.ads, 3veacodu.adb, 3vexpect.adb, 3vsoccon.ads,
3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb, 3zsoccon.ads,
3zsocthi.adb, 3zsocthi.ads, 50system.ads, 51system.ads,
55system.ads, 56osinte.adb, 56osinte.ads, 56taprop.adb,
56taspri.ads, 56tpopsp.adb, 57system.ads, 58system.ads,
59system.ads, 5aml-tgt.adb, 5bml-tgt.adb, 5csystem.ads,
5dsystem.ads, 5fosinte.adb, 5gml-tgt.adb, 5hml-tgt.adb,
5isystem.ads, 5lparame.adb, 5msystem.ads, 5psystem.ads,
5sml-tgt.adb, 5sosprim.adb, 5stpopsp.adb, 5tsystem.ads,
5usystem.ads, 5vml-tgt.adb, 5vsymbol.adb, 5vtraent.adb,
5vtraent.ads, 5wml-tgt.adb, 5xparame.ads, 5xsystem.ads,
5xvxwork.ads, 5yparame.ads, 5ytiitho.adb, 5zinit.adb,
5zml-tgt.adb, 5zparame.ads, 5ztaspri.ads, 5ztfsetr.adb,
5zthrini.adb, 5ztiitho.adb, 5ztpopsp.adb, 7stfsetr.adb,
7straces.adb, 7strafor.adb, 7strafor.ads, 7stratas.adb,
a-excach.adb, a-exexda.adb, a-exexpr.adb, a-exextr.adb,
a-exstat.adb, a-strsup.adb, a-strsup.ads, a-stwisu.adb,
a-stwisu.ads, bld.adb, bld.ads, bld-io.adb,
bld-io.ads, clean.adb, clean.ads, ctrl_c.c,
erroutc.adb, erroutc.ads, errutil.adb, errutil.ads,
err_vars.ads, final.c, g-arrspl.adb, g-arrspl.ads,
g-boubuf.adb, g-boubuf.ads, g-boumai.ads, g-bubsor.adb,
g-bubsor.ads, g-comver.adb, g-comver.ads, g-ctrl_c.ads,
g-dynhta.adb, g-dynhta.ads, g-eacodu.adb, g-excact.adb,
g-excact.ads, g-heasor.adb, g-heasor.ads, g-memdum.adb,
g-memdum.ads, gnatclean.adb, gnatsym.adb, g-pehage.adb,
g-pehage.ads, g-perhas.ads, gpr2make.adb, gpr2make.ads,
gprcmd.adb, gprep.adb, gprep.ads, g-semaph.adb,
g-semaph.ads, g-string.adb, g-string.ads, g-strspl.ads,
g-wistsp.ads, i-vthrea.adb, i-vthrea.ads, i-vxwoio.adb,
i-vxwoio.ads, Makefile.generic, Makefile.prolog, Makefile.rtl,
prep.adb, prep.ads, prepcomp.adb, prepcomp.ads,
prj-err.adb, prj-err.ads, s-boarop.ads, s-carsi8.adb,
s-carsi8.ads, s-carun8.adb, s-carun8.ads, s-casi16.adb,
s-casi16.ads, s-casi32.adb, s-casi32.ads, s-casi64.adb,
s-casi64.ads, s-casuti.adb, s-casuti.ads, s-caun16.adb,
s-caun16.ads, s-caun32.adb, s-caun32.ads, s-caun64.adb,
s-caun64.ads, scng.adb, scng.ads, s-exnint.adb,
s-exnllf.adb, s-exnlli.adb, s-expint.adb, s-explli.adb,
s-geveop.adb, s-geveop.ads, s-hibaen.ads, s-htable.adb,
s-htable.ads, sinput-c.adb, sinput-c.ads, s-memcop.ads,
socket.c, s-purexc.ads, s-scaval.adb, s-stopoo.adb,
s-strcom.adb, s-strcom.ads, s-strxdr.adb, s-rident.ads,
s-thread.adb, s-thread.ads, s-tpae65.adb, s-tpae65.ads,
s-tporft.adb, s-traent.adb, s-traent.ads, styleg.adb,
styleg.ads, styleg-c.adb, styleg-c.ads, s-veboop.adb,
s-veboop.ads, s-vector.ads, symbols.adb, symbols.ads,
tb-alvms.c, tb-alvxw.c, tempdir.adb, tempdir.ads,
vms_conv.ads, vms_conv.adb, vms_data.ads,
vxaddr2line.adb: Files added. Merge with ACT tree.
* 4dintnam.ads, 4mintnam.ads, 4uintnam.ads, 52system.ads,
5dosinte.ads, 5etpopse.adb, 5mosinte.ads, 5qosinte.adb,
5qosinte.ads, 5qstache.adb, 5qtaprop.adb, 5qtaspri.ads,
5stpopse.adb, 5uintman.adb, 5uosinte.ads, adafinal.c,
g-enblsp.adb, io-aux.c, scn-nlit.adb, scn-slit.adb,
s-exnflt.ads, s-exngen.adb, s-exngen.ads, s-exnlfl.ads,
s-exnlin.ads, s-exnsfl.ads, s-exnsin.ads, s-exnssi.ads,
s-expflt.ads, s-expgen.adb, s-expgen.ads, s-explfl.ads,
s-explin.ads, s-expllf.ads, s-expsfl.ads, s-expsin.ads,
s-expssi.ads, style.adb: Files removed. Merge with ACT tree.
* 1ic.ads, 31soccon.ads, 31soliop.ads, 3asoccon.ads,
3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3ssoccon.ads,
3ssoliop.ads, 3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads,
3wsoliop.ads, 41intnam.ads, 42intnam.ads, 4aintnam.ads,
4cintnam.ads, 4gintnam.ads, 4hexcpol.adb, 4hintnam.ads,
4lintnam.ads, 4nintnam.ads, 4ointnam.ads, 4onumaux.ads,
4pintnam.ads, 4sintnam.ads, 4vcaldel.adb, 4vcalend.adb,
4vintnam.ads, 4wexcpol.adb, 4wintnam.ads, 4zintnam.ads,
51osinte.adb, 51osinte.ads, 52osinte.adb, 52osinte.ads,
53osinte.ads, 54osinte.ads, 5aosinte.adb, 5aosinte.ads,
5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bosinte.ads,
5bsystem.ads, 5cosinte.ads, 5esystem.ads, 5fintman.adb,
5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gosinte.ads,
5gproinf.ads, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.ads,
5gtpgetc.adb, 5hosinte.adb, 5hosinte.ads, 5hsystem.ads,
5htaprop.adb, 5htaspri.ads, 5htraceb.adb, 5iosinte.adb,
5itaprop.adb, 5itaspri.ads, 5ksystem.ads, 5kvxwork.ads,
5lintman.adb, 5lml-tgt.adb, 5losinte.ads, 5lsystem.ads,
5mvxwork.ads, 5ninmaop.adb, 5nintman.adb, 5nosinte.ads,
5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
5posprim.adb, 5pvxwork.ads, 5sintman.adb, 5sosinte.adb,
5sosinte.ads, 5ssystem.ads, 5staprop.adb, 5stasinf.ads,
5staspri.ads, 5svxwork.ads, 5tosinte.ads, 5vasthan.adb,
5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
5vmastop.adb, 5vosinte.adb, 5vosinte.ads, 5vosprim.adb,
5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
5vtpopde.ads, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
5wosprim.adb, 5wsystem.ads, 5wtaprop.adb, 5wtaspri.ads,
5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb,
5zosinte.ads, 5zosprim.adb, 5zsystem.ads, 5ztaprop.adb,
6vcpp.adb, 6vcstrea.adb, 6vinterf.ads, 7sinmaop.adb,
7sintman.adb, 7sosinte.adb, 7sosprim.adb, 7staprop.adb,
7staspri.ads, 7stpopsp.adb, 7straceb.adb, 9drpc.adb,
a-caldel.adb, a-caldel.ads, a-charac.ads, a-colien.ads,
a-comlin.adb, adaint.c, adaint.h, ada-tree.def,
a-diocst.adb, a-diocst.ads, a-direio.adb, a-except.adb,
a-except.ads, a-excpol.adb, a-exctra.adb, a-exctra.ads,
a-filico.adb, a-interr.adb, a-intsig.adb, a-intsig.ads,
ali.adb, ali.ads, ali-util.adb, ali-util.ads,
a-ngcefu.adb, a-ngcoty.adb, a-ngelfu.adb, a-nudira.adb,
a-nudira.ads, a-nuflra.adb, a-nuflra.ads, a-reatim.adb,
a-reatim.ads, a-retide.ads, a-sequio.adb, a-siocst.adb,
a-siocst.ads, a-ssicst.adb, a-ssicst.ads, a-strbou.adb,
a-strbou.ads, a-strfix.adb, a-strmap.adb, a-strsea.ads,
a-strunb.adb, a-strunb.ads, a-ststio.adb, a-stunau.adb,
a-stunau.ads, a-stwibo.adb, a-stwibo.ads, a-stwifi.adb,
a-stwima.adb, a-stwiun.adb, a-stwiun.ads, a-tags.adb,
a-tags.ads, a-tasatt.adb, a-taside.adb, a-teioed.adb,
a-textio.adb, a-textio.ads, a-tienau.adb, a-tifiio.adb,
a-tiflau.adb, a-tiflio.adb, a-tigeau.adb, a-tigeau.ads,
a-tiinau.adb, a-timoau.adb, a-tiocst.adb, a-tiocst.ads,
atree.adb, atree.ads, a-witeio.adb, a-witeio.ads,
a-wtcstr.adb, a-wtcstr.ads, a-wtdeio.adb, a-wtedit.adb,
a-wtenau.adb, a-wtflau.adb, a-wtinau.adb, a-wtmoau.adb,
bcheck.adb, binde.adb, bindgen.adb, bindusg.adb,
checks.adb, checks.ads, cio.c, comperr.adb,
comperr.ads, csets.adb, cstand.adb, cstreams.c,
debug_a.adb, debug_a.ads, debug.adb, decl.c,
einfo.adb, einfo.ads, errout.adb, errout.ads,
eval_fat.adb, eval_fat.ads, exp_aggr.adb, expander.adb,
expander.ads, exp_attr.adb, exp_ch11.adb, exp_ch13.adb,
exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb,
exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads,
exp_ch8.adb, exp_ch9.adb, exp_code.adb, exp_dbug.adb,
exp_dbug.ads, exp_disp.adb, exp_dist.adb, expect.c,
exp_fixd.adb, exp_imgv.adb, exp_intr.adb, exp_pakd.adb,
exp_prag.adb, exp_strm.adb, exp_strm.ads, exp_tss.adb,
exp_tss.ads, exp_util.adb, exp_util.ads, exp_vfpt.adb,
fe.h, fmap.adb, fmap.ads, fname.adb,
fname.ads, fname-uf.adb, fname-uf.ads, freeze.adb,
freeze.ads, frontend.adb, g-awk.adb, g-awk.ads,
g-busora.adb, g-busora.ads, g-busorg.adb, g-busorg.ads,
g-casuti.adb, g-casuti.ads, g-catiio.adb, g-catiio.ads,
g-cgi.adb, g-cgi.ads, g-cgicoo.adb, g-cgicoo.ads,
g-cgideb.adb, g-cgideb.ads, g-comlin.adb, g-comlin.ads,
g-crc32.adb, g-crc32.ads, g-debpoo.adb, g-debpoo.ads,
g-debuti.adb, g-debuti.ads, g-diopit.adb, g-diopit.ads,
g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-dyntab.ads,
g-except.ads, g-exctra.adb, g-exctra.ads, g-expect.adb,
g-expect.ads, g-hesora.adb, g-hesora.ads, g-hesorg.adb,
g-hesorg.ads, g-htable.adb, g-htable.ads, gigi.h,
g-io.adb, g-io.ads, g-io_aux.adb, g-io_aux.ads,
g-locfil.adb, g-locfil.ads, g-md5.adb, g-md5.ads,
gmem.c, gnat1drv.adb, gnatbind.adb, gnatchop.adb,
gnatcmd.adb, gnatfind.adb, gnatkr.adb, gnatlbr.adb,
gnatlink.adb, gnatls.adb, gnatmake.adb, gnatmem.adb,
gnatname.adb, gnatprep.adb, gnatprep.ads, gnatpsta.adb,
gnatxref.adb, g-os_lib.adb, g-os_lib.ads, g-regexp.adb,
g-regexp.ads, g-regist.adb, g-regist.ads, g-regpat.adb,
g-regpat.ads, g-soccon.ads, g-socket.adb, g-socket.ads,
g-socthi.adb, g-socthi.ads, g-soliop.ads, g-souinf.ads,
g-speche.adb, g-speche.ads, g-spipat.adb, g-spipat.ads,
g-spitbo.adb, g-spitbo.ads, g-sptabo.ads, g-sptain.ads,
g-sptavs.ads, g-table.adb, g-table.ads, g-tasloc.adb,
g-tasloc.ads, g-thread.adb, g-thread.ads, g-traceb.adb,
g-traceb.ads, g-trasym.adb, g-trasym.ads, hostparm.ads,
i-c.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads,
i-cstrin.adb, i-cstrin.ads, impunit.adb, init.c,
inline.adb, interfac.ads, i-pacdec.ads, itypes.adb,
itypes.ads, i-vxwork.ads, lang.opt, lang-specs.h,
layout.adb, lib.adb, lib.ads, lib-list.adb,
lib-load.adb, lib-load.ads, lib-sort.adb, lib-util.adb,
lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads,
link.c, live.adb, make.adb, make.ads,
Makefile.adalib, Makefile.in, Make-lang.in, makeusg.adb,
mdll.adb, mdll-fil.adb, mdll-fil.ads, mdll-utl.adb,
mdll-utl.ads, memroot.adb, memroot.ads, memtrack.adb,
misc.c, mkdir.c, mlib.adb, mlib.ads,
mlib-fil.adb, mlib-fil.ads, mlib-prj.adb, mlib-prj.ads,
mlib-tgt.adb, mlib-tgt.ads, mlib-utl.adb, mlib-utl.ads,
namet.adb, namet.ads, namet.h, nlists.ads,
nlists.h, nmake.adt, opt.adb, opt.ads,
osint.adb, osint.ads, osint-b.adb, osint-c.adb,
par.adb, par-ch10.adb, par-ch11.adb, par-ch2.adb,
par-ch3.adb, par-ch4.adb, par-ch5.adb, par-ch6.adb,
par-ch9.adb, par-endh.adb, par-labl.adb, par-load.adb,
par-prag.adb, par-sync.adb, par-tchk.adb, par-util.adb,
prj.adb, prj.ads, prj-attr.adb, prj-attr.ads,
prj-com.adb, prj-com.ads, prj-dect.adb, prj-dect.ads,
prj-env.adb, prj-env.ads, prj-ext.adb, prj-ext.ads,
prj-makr.adb, prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads,
prj-pars.adb, prj-pars.ads, prj-part.adb, prj-part.ads,
prj-pp.adb, prj-pp.ads, prj-proc.adb, prj-proc.ads,
prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads,
prj-util.adb, prj-util.ads, raise.c, raise.h,
repinfo.adb, repinfo.h, restrict.adb, restrict.ads,
rident.ads, rtsfind.adb, rtsfind.ads, s-addima.ads,
s-arit64.adb, s-assert.adb, s-assert.ads, s-atacco.adb,
s-atacco.ads, s-auxdec.adb, s-auxdec.ads, s-bitops.adb,
scans.ads, scn.adb, scn.ads, s-crc32.adb,
s-crc32.ads, s-direio.adb, sem.adb, sem.ads,
sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb,
sem_case.ads, sem_cat.adb, sem_cat.ads, sem_ch10.adb,
sem_ch11.adb, sem_ch12.adb, sem_ch12.ads, sem_ch13.adb,
sem_ch13.ads, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb,
sem_ch5.adb, sem_ch5.ads, sem_ch6.adb, sem_ch6.ads,
sem_ch7.adb, sem_ch7.ads, sem_ch8.adb, sem_ch8.ads,
sem_ch9.adb, sem_disp.adb, sem_disp.ads, sem_dist.adb,
sem_elab.adb, sem_eval.adb, sem_eval.ads, sem_intr.adb,
sem_maps.adb, sem_mech.adb, sem_prag.adb, sem_prag.ads,
sem_res.adb, sem_res.ads, sem_type.adb, sem_type.ads,
sem_util.adb, sem_util.ads, sem_warn.adb, s-errrep.adb,
s-errrep.ads, s-exctab.adb, s-exctab.ads, s-exnint.ads,
s-exnllf.ads, s-exnlli.ads, s-expint.ads, s-explli.ads,
s-expuns.ads, s-fatflt.ads, s-fatgen.adb, s-fatgen.ads,
s-fatlfl.ads, s-fatllf.ads, s-fatsfl.ads, s-fileio.adb,
s-fileio.ads, s-finimp.adb, s-finimp.ads, s-finroo.adb,
s-finroo.ads, sfn_scan.adb, s-gloloc.adb, s-gloloc.ads,
s-imgdec.adb, s-imgenu.adb, s-imgrea.adb, s-imgwch.adb,
sinfo.adb, sinfo.ads, s-inmaop.ads, sinput.adb,
sinput.ads, sinput-d.adb, sinput-l.adb, sinput-l.ads,
sinput-p.adb, sinput-p.ads, s-interr.adb, s-interr.ads,
s-intman.ads, s-maccod.ads, s-mastop.adb, s-mastop.ads,
s-memory.adb, s-memory.ads, snames.adb, snames.ads,
snames.h, s-osprim.ads, s-parame.ads, s-parint.ads,
s-pooloc.adb, s-pooloc.ads, s-poosiz.adb, sprint.adb,
s-proinf.ads, s-scaval.ads, s-secsta.adb, s-secsta.ads,
s-sequio.adb, s-shasto.adb, s-shasto.ads, s-soflin.ads,
s-stache.adb, s-stache.ads, s-stalib.adb, s-stalib.ads,
s-stoele.ads, s-stopoo.ads, s-stratt.adb, s-stratt.ads,
s-strops.adb, s-strops.ads, s-taasde.adb, s-taasde.ads,
s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads,
s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprob.ads,
s-taprop.ads, s-tarest.adb, s-tarest.ads, s-tasdeb.adb,
s-tasdeb.ads, s-tasinf.adb, s-tasinf.ads, s-tasini.adb,
s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb,
s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tasres.ads,
s-tassta.adb, s-tassta.ads, s-tasuti.adb, s-tasuti.ads,
s-tataat.adb, s-tataat.ads, s-tpinop.adb, s-tpinop.ads,
s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tpobop.ads,
s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads,
stringt.adb, stringt.ads, stringt.h, style.ads,
stylesw.adb, stylesw.ads, s-unstyp.ads, s-vaflop.ads,
s-valrea.adb, s-valuti.adb, s-vercon.adb, s-vmexta.adb,
s-wchcnv.ads, s-wchcon.ads, s-widcha.adb, switch.adb,
switch.ads, switch-b.adb, switch-c.adb, switch-m.adb,
s-wwdcha.adb, s-wwdwch.adb, sysdep.c, system.ads,
table.adb, table.ads, targparm.adb, targparm.ads,
targtyps.c, tbuild.adb, tbuild.ads, tracebak.c,
trans.c, tree_io.adb, treepr.adb, treeprs.adt,
ttypes.ads, types.ads, types.h, uintp.adb,
uintp.ads, uintp.h, uname.adb, urealp.adb,
urealp.ads, urealp.h, usage.adb, utils2.c,
utils.c, validsw.adb, validsw.ads, widechar.adb,
xeinfo.adb, xnmake.adb, xref_lib.adb, xref_lib.ads,
xr_tabls.adb, xr_tabls.ads, xtreeprs.adb, xsnames.adb,
einfo.h, sinfo.h, treeprs.ads, nmake.ads, nmake.adb,
gnatvsn.ads: Merge with ACT tree.
* gnatvsn.adb: Rewritten in a simpler and more efficient way.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@72751 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/sem_prag.adb')
| -rw-r--r-- | gcc/ada/sem_prag.adb | 1887 |
1 files changed, 1516 insertions, 371 deletions
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index d8debec4990..57712b06d9c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -42,6 +42,8 @@ with Exp_Dist; use Exp_Dist; with Fname; use Fname; with Hostparm; use Hostparm; with Lib; use Lib; +with Lib.Writ; use Lib.Writ; +with Lib.Xref; use Lib.Xref; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; @@ -50,6 +52,7 @@ with Output; use Output; with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; @@ -146,9 +149,6 @@ package body Sem_Prag is -- it is set to Uppercase or Lowercase, then a new string literal with -- appropriate casing is constructed. - function Is_Generic_Subprogram (Id : Entity_Id) return Boolean; - -- Return True if Id is a generic procedure or a function - function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id; -- If Def_Id refers to a renamed subprogram, then the base subprogram -- (the original one, following the renaming chain) is returned. @@ -159,15 +159,6 @@ package body Sem_Prag is -- Elaborate_All pragma. Entity name for unit and its parents is -- taken from item in previous with_clause that mentions the unit. - Locking_Policy_Sloc : Source_Ptr := No_Location; - Queuing_Policy_Sloc : Source_Ptr := No_Location; - Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location; - -- These global variables remember the location of a previous locking, - -- queuing or task dispatching policy pragma, so that appropriate error - -- messages can be generated for inconsistent pragmas. Note that it is - -- fine that these are global locations, because the check for consistency - -- is over the entire program. - ------------------------------- -- Adjust_External_Name_Case -- ------------------------------- @@ -542,7 +533,8 @@ package body Sem_Prag is procedure Set_Exported (E : Entity_Id; Arg : Node_Id); -- This procedure sets the Is_Exported flag for the given entity, -- checking that the entity was not previously imported. Arg is - -- the argument that specified the entity. + -- the argument that specified the entity. A check is also made + -- for exporting inappropriate entities. procedure Set_Extended_Import_Export_External_Name (Internal_Ent : Entity_Id; @@ -773,10 +765,11 @@ package body Sem_Prag is -- Finally, we have a real error else - Error_Pragma_Arg - ("argument for pragma% must be a static expression", Argx); + Error_Msg_Name_1 := Chars (N); + Flag_Non_Static_Expr + ("argument for pragma% must be a static expression!", Argx); + raise Pragma_Exit; end if; - end Check_Arg_Is_Static_Expression; --------------------------------- @@ -869,7 +862,7 @@ package body Sem_Prag is -- Otherwise warn if obviously not main program elsif Present (Parameter_Specifications (Specification (P))) - or else not Is_Library_Level_Entity (Defining_Entity (P)) + or else not Is_Compilation_Unit (Defining_Entity (P)) then Error_Msg_Name_1 := Chars (N); Error_Msg_N @@ -896,13 +889,13 @@ package body Sem_Prag is end if; declare - Prot_Proc : Entity_Id := Empty; - Prot_Type : Entity_Id; - Found : Boolean := False; + Handler_Proc : Entity_Id := Empty; + Proc_Scope : Entity_Id; + Found : Boolean := False; begin if not Is_Overloaded (Arg1_X) then - Prot_Proc := Entity (Arg1_X); + Handler_Proc := Entity (Arg1_X); else declare @@ -912,14 +905,14 @@ package body Sem_Prag is begin Get_First_Interp (Arg1_X, Index, It); while Present (It.Nam) loop - Prot_Proc := It.Nam; + Handler_Proc := It.Nam; - if Ekind (Prot_Proc) = E_Procedure - and then No (First_Formal (Prot_Proc)) + if Ekind (Handler_Proc) = E_Procedure + and then No (First_Formal (Handler_Proc)) then if not Found then Found := True; - Set_Entity (Arg1_X, Prot_Proc); + Set_Entity (Arg1_X, Handler_Proc); Set_Is_Overloaded (Arg1_X, False); else Error_Pragma_Arg @@ -935,38 +928,54 @@ package body Sem_Prag is ("argument of pragma% must be parameterless procedure", Arg1); else - Prot_Proc := Entity (Arg1_X); + Handler_Proc := Entity (Arg1_X); end if; end; end if; - Prot_Type := Scope (Prot_Proc); + Proc_Scope := Scope (Handler_Proc); + + -- On AAMP only, a pragma Interrupt_Handler is supported for + -- nonprotected parameterless procedures. + + if AAMP_On_Target + and then Prag_Id = Pragma_Interrupt_Handler + then + if Ekind (Handler_Proc) /= E_Procedure then + Error_Pragma_Arg + ("argument of pragma% must be a procedure", Arg1); + end if; - if Ekind (Prot_Proc) /= E_Procedure - or else Ekind (Prot_Type) /= E_Protected_Type + elsif Ekind (Handler_Proc) /= E_Procedure + or else Ekind (Proc_Scope) /= E_Protected_Type then Error_Pragma_Arg - ("argument of pragma% must be protected procedure", - Arg1); + ("argument of pragma% must be protected procedure", Arg1); + end if; + + if (not AAMP_On_Target or else Prag_Id = Pragma_Attach_Handler) + and then Ekind (Proc_Scope) = E_Protected_Type + then + if Parent (N) /= + Protected_Definition (Parent (Proc_Scope)) + then + Error_Pragma ("pragma% must be in protected definition"); + end if; end if; - if not Is_Library_Level_Entity (Prot_Type) then + if not Is_Library_Level_Entity (Proc_Scope) + or else (AAMP_On_Target + and then not Is_Library_Level_Entity (Handler_Proc)) + then Error_Pragma_Arg - ("pragma% requires library level entity", Arg1); + ("pragma% requires library-level entity", Arg1); end if; - if Present (First_Formal (Prot_Proc)) then + if Present (First_Formal (Handler_Proc)) then Error_Pragma_Arg ("argument of pragma% must be parameterless procedure", Arg1); end if; - - if Parent (N) /= - Protected_Definition (Parent (Prot_Type)) - then - Error_Pragma ("pragma% must be in protected definition"); - end if; - end; end Check_Interrupt_Or_Attach_Handler; @@ -1010,7 +1019,6 @@ package body Sem_Prag is end loop; Error_Pragma ("pragma% is not in declarative part or package spec"); - end Check_Is_In_Decl_Part_Or_Package_Spec; ------------------------- @@ -1073,6 +1081,7 @@ package body Sem_Prag is -- Note: for convenience in writing this procedure, in addition to -- the officially (i.e. by spec) allowed argument which is always -- a constraint, it also allows ranges and discriminant associations. + -- Above is not clear ??? procedure Check_Static_Constraint (Constr : Node_Id) is @@ -1086,8 +1095,8 @@ package body Sem_Prag is procedure Require_Static (E : Node_Id) is begin if not Is_OK_Static_Expression (E) then - Error_Msg_N - ("non-static constraint not allowed in Unchecked_Union", E); + Flag_Non_Static_Expr + ("non-static constraint not allowed in Unchecked_Union!", E); raise Pragma_Exit; end if; end Require_Static; @@ -1149,7 +1158,6 @@ package body Sem_Prag is Plist : List_Id; Parent_Node : Node_Id; Unit_Name : Entity_Id; - Valid : Boolean := True; Unit_Kind : Node_Kind; Unit_Node : Node_Id; Sindex : Source_File_Index; @@ -1157,7 +1165,6 @@ package body Sem_Prag is begin if not Is_List_Member (N) then Pragma_Misplaced; - Valid := False; else Plist := List_Containing (N); @@ -1285,7 +1292,6 @@ package body Sem_Prag is end if; end if; end if; - end Check_Valid_Library_Unit_Pragma; ------------------ @@ -1341,7 +1347,6 @@ package body Sem_Prag is and then Defining_Entity (Parent (N)) /= Current_Scope then return Defining_Entity (Parent (N)); - else return Current_Scope; end if; @@ -1519,7 +1524,6 @@ package body Sem_Prag is Next (Item); end loop; - end Is_Before_First_Decl; ----------------------------- @@ -1564,7 +1568,6 @@ package body Sem_Prag is else return False; end if; - end Is_Configuration_Pragma; ---------------------- @@ -1617,9 +1620,16 @@ package body Sem_Prag is Set_Is_Atomic (Underlying_Type (E)); end if; - Set_Is_Volatile (E); + -- Attribute belongs on the base type. If the + -- view of the type is currently private, it also + -- belongs on the underlying type. + + Set_Is_Volatile (Base_Type (E)); Set_Is_Volatile (Underlying_Type (E)); + Set_Treat_As_Volatile (E); + Set_Treat_As_Volatile (Underlying_Type (E)); + elsif K = N_Object_Declaration or else (K = N_Component_Declaration and then Original_Record_Component (E) = E) @@ -1631,6 +1641,17 @@ package body Sem_Prag is if Prag_Id /= Pragma_Volatile then Set_Is_Atomic (E); + -- If the object declaration has an explicit + -- initialization, a temporary may have to be + -- created to hold the expression, to insure + -- that access to the object remain atomic. + + if Nkind (Parent (E)) = N_Object_Declaration + and then Present (Expression (Parent (E))) + then + Set_Has_Delayed_Freeze (E); + end if; + -- An interesting improvement here. If an object of type X -- is declared atomic, and the type X is not atomic, that's -- a pity, since it may not have appropraite alignment etc. @@ -1652,6 +1673,7 @@ package body Sem_Prag is end if; Set_Is_Volatile (E); + Set_Treat_As_Volatile (E); else Error_Pragma_Arg @@ -1762,7 +1784,7 @@ package body Sem_Prag is -- with a warning in the non-VMS case. else - if not OpenVMS_On_Target then + if Warn_On_Export_Import and not OpenVMS_On_Target then Error_Msg_N ("?unrecognized convention name, C assumed", Expression (Arg1)); @@ -1893,6 +1915,12 @@ package body Sem_Prag is Comp_Unit := Get_Source_Unit (E); Set_Convention_From_Pragma (E); + -- Treat a pragma Import as an implicit body, for GPS use. + + if Prag_Id = Pragma_Import then + Generate_Reference (E, Id, 'b'); + end if; + E1 := E; loop E1 := Homonym (E1); @@ -1904,10 +1932,13 @@ package body Sem_Prag is if Comp_Unit = Get_Source_Unit (E1) then Set_Convention_From_Pragma (E1); + + if Prag_Id = Pragma_Import then + Generate_Reference (E, Id, 'b'); + end if; end if; end loop; end if; - end Process_Convention; ----------------------------------------------------- @@ -1925,6 +1956,12 @@ package body Sem_Prag is begin GNAT_Pragma; + + 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); @@ -1967,7 +2004,6 @@ package body Sem_Prag is Set_Exception_Code (Def_Id, Code_Val); end if; end if; - end Process_Extended_Import_Export_Exception_Pragma; ------------------------------------------------- @@ -2000,7 +2036,6 @@ package body Sem_Prag is end if; Check_Arg_Is_Local_Name (Arg_Internal); - end Process_Extended_Import_Export_Internal_Arg; -------------------------------------------------- @@ -2012,7 +2047,7 @@ package body Sem_Prag is Arg_External : Node_Id; Arg_Size : Node_Id) is - Def_Id : Entity_Id; + Def_Id : Entity_Id; begin Process_Extended_Import_Export_Internal_Arg (Arg_Internal); @@ -2049,7 +2084,6 @@ package body Sem_Prag is -- Export_Object case if Prag_Id = Pragma_Export_Object then - if not Is_Library_Level_Entity (Def_Id) then Error_Pragma_Arg ("argument for pragma% must be library level entity", @@ -2066,7 +2100,7 @@ package body Sem_Prag is Arg_Internal); end if; - if Is_Exported (Def_Id) then + if Warn_On_Export_Import and then Is_Exported (Def_Id) then Error_Msg_N ("?duplicate Export_Object pragma", N); else @@ -2087,24 +2121,45 @@ package body Sem_Prag is ("cannot import a constant", Arg_Internal); end if; - if Has_Discriminants (Etype (Def_Id)) then + if Warn_On_Export_Import + and then Has_Discriminants (Etype (Def_Id)) + then Error_Msg_N ("imported value must be initialized?", Arg_Internal); end if; - if Is_Access_Type (Etype (Def_Id)) then + if Warn_On_Export_Import + and then Is_Access_Type (Etype (Def_Id)) + then Error_Pragma_Arg ("cannot import object of an access type?", Arg_Internal); end if; - if Is_Imported (Def_Id) then + if Warn_On_Export_Import + and then Is_Imported (Def_Id) + then Error_Msg_N ("?duplicate Import_Object pragma", N); + + -- Check for explicit initialization present. Note that an + -- initialization that generated by the code generator, e.g. + -- for an access type, does not count here. + + elsif Present (Expression (Parent (Def_Id))) + and then + Comes_From_Source + (Original_Node (Expression (Parent (Def_Id)))) + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Pragma_Arg + ("no initialization allowed for declaration of& #", + "\imported entities cannot be initialized ('R'M' 'B.1(24))", + Arg1); else Set_Imported (Def_Id); + Note_Possible_Modification (Arg_Internal); end if; end if; - end Process_Extended_Import_Export_Object_Pragma; ------------------------------------------------------ @@ -2128,21 +2183,62 @@ package body Sem_Prag is Match : Boolean; Dval : Node_Id; - function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean; + function Same_Base_Type + (Ptype : Node_Id; + Formal : Entity_Id) + return Boolean; -- Determines if Ptype references the type of Formal. Note that - -- only the base types need to match according to the spec. + -- only the base types need to match according to the spec. Ptype + -- here is the argument from the pragma, which is either a type + -- name, or an access attribute. + + -------------------- + -- Same_Base_Type -- + -------------------- function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is + Ftyp : constant Entity_Id := Base_Type (Etype (Formal)); + Pref : Node_Id; + begin - Find_Type (Ptype); + -- Case where pragma argument is typ'Access - if not Is_Entity_Name (Ptype) - or else Entity (Ptype) = Any_Type + if Nkind (Ptype) = N_Attribute_Reference + and then Attribute_Name (Ptype) = Name_Access then - raise Pragma_Exit; - end if; + Pref := Prefix (Ptype); + Find_Type (Pref); + + if not Is_Entity_Name (Pref) + or else Entity (Pref) = Any_Type + then + raise Pragma_Exit; + end if; + + -- We have a match if the corresponding argument is of an + -- anonymous access type, and its designicated type matches + -- the type of the prefix of the access attribute - return Base_Type (Entity (Ptype)) = Base_Type (Etype (Formal)); + return Ekind (Ftyp) = E_Anonymous_Access_Type + and then Base_Type (Entity (Pref)) = + Base_Type (Etype (Designated_Type (Ftyp))); + + -- Case where pragma argument is a type name + + else + Find_Type (Ptype); + + if not Is_Entity_Name (Ptype) + or else Entity (Ptype) = Any_Type + then + raise Pragma_Exit; + end if; + + -- We have a match if the corresponding argument is of + -- the type given in the pragma (comparing base types) + + return Base_Type (Entity (Ptype)) = Ftyp; + end if; end Same_Base_Type; -- Start of processing for @@ -2189,6 +2285,13 @@ package body Sem_Prag is then Match := False; + elsif Etype (Def_Id) /= Standard_Void_Type + and then + (Chars (N) = Name_Export_Procedure + or else Chars (N) = Name_Import_Procedure) + then + Match := False; + -- Test parameter types if given. Note that this parameter -- has not been analyzed (and must not be, since it is -- semantic nonsense), so we get it as the parser left it. @@ -2301,20 +2404,29 @@ package body Sem_Prag is -- Import pragmas must be be for imported entities - if (Prag_Id = Pragma_Import_Function - or else - Prag_Id = Pragma_Import_Procedure - or else - Prag_Id = Pragma_Import_Valued_Procedure) + if Prag_Id = Pragma_Import_Function + or else + Prag_Id = Pragma_Import_Procedure + or else + Prag_Id = Pragma_Import_Valued_Procedure then if not Is_Imported (Ent) then Error_Pragma ("pragma Import or Interface must precede pragma%"); end if; - -- For the Export cases, the pragma Export is sufficient to set - -- the entity as exported, if it is not exported already. We - -- leave the default Ada convention in this case. + -- Here we have the Export case which can set the entity as exported + + -- But does not do so if the specified external name is null, + -- since that is taken as a signal in DEC Ada 83 (with which + -- we want to be compatible) to request no external name. + + elsif Nkind (Arg_External) = N_String_Literal + and then String_Length (Strval (Arg_External)) = 0 + then + null; + + -- In all other cases, set entit as exported else Set_Exported (Ent, Arg_Internal); @@ -2355,7 +2467,6 @@ package body Sem_Prag is -- nonsense, so we get it in exactly as the parser left it. if Present (Arg_Mechanism) then - declare Formal : Entity_Id; Massoc : Node_Id; @@ -2498,7 +2609,7 @@ package body Sem_Prag is null; else - Error_Msg_NE + Error_Msg_FE ("default value for optional formal& is non-static!", Arg_First_Optional_Parameter, Formal); end if; @@ -2563,7 +2674,9 @@ package body Sem_Prag is then -- User initialization is not allowed for imported object, but -- the object declaration may contain a default initialization, - -- that will be discarded. + -- that will be discarded. Note that an explicit initialization + -- only counts if it comes from source, otherwise it is simply + -- the code generator making an implicit initialization explicit. if Present (Expression (Parent (Def_Id))) and then Comes_From_Source (Expression (Parent (Def_Id))) @@ -2578,6 +2691,18 @@ package body Sem_Prag is Set_Imported (Def_Id); Set_Is_Public (Def_Id); Process_Interface_Name (Def_Id, Arg3, Arg4); + + -- It is not possible to import a constant of an unconstrained + -- array type (e.g. string) because there is no simple way to + -- write a meaningful subtype for it. + + if Is_Array_Type (Etype (Def_Id)) + and then not Is_Constrained (Etype (Def_Id)) + then + Error_Msg_NE + ("imported constant& must have a constrained subtype", + N, Def_Id); + end if; end if; elsif Is_Subprogram (Def_Id) @@ -2599,6 +2724,14 @@ package body Sem_Prag is then null; + -- If it is not a subprogram, it must be in an outer + -- scope and pragma does not apply. + + elsif not Is_Subprogram (Def_Id) + and then not Is_Generic_Subprogram (Def_Id) + then + null; + -- Verify that the homonym is in the same declarative -- part (not just the same scope). @@ -2624,6 +2757,30 @@ package body Sem_Prag is -- always referenced from another object file. Set_Is_Public (Def_Id); + + -- Verify that the subprogram does not have a completion + -- through a renaming declaration. For other completions + -- the pragma appears as a too late representation. + + declare + Decl : constant Node_Id := Unit_Declaration_Node (Def_Id); + begin + if Present (Decl) + and then Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + and then + Nkind + (Unit_Declaration_Node + (Corresponding_Body (Decl))) = + N_Subprogram_Renaming_Declaration + then + Error_Msg_Sloc := Sloc (Def_Id); + Error_Msg_NE ("cannot import&#," & + " already completed by a renaming", + N, Def_Id); + end if; + end; + Set_Has_Completion (Def_Id); Process_Interface_Name (Def_Id, Arg3, Arg4); end if; @@ -2671,7 +2828,6 @@ package body Sem_Prag is Set_Body_Required (Cunit, False); end; end if; - end Process_Import_Or_Interface; -------------------- @@ -2693,18 +2849,54 @@ package body Sem_Prag is procedure Set_Inline_Flags (Subp : Entity_Id); -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp + function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean; + -- Do not set the inline flag if body is available and contains + -- exception handlers, to prevent undefined symbols at link time. + + ---------------------------- + -- Back_End_Cannot_Inline -- + ---------------------------- + + function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is + Decl : Node_Id := Unit_Declaration_Node (Subp); + + begin + if Nkind (Decl) = N_Subprogram_Body then + return + Present + (Exception_Handlers (Handled_Statement_Sequence (Decl))); + + elsif Nkind (Decl) = N_Subprogram_Declaration + and then Present (Corresponding_Body (Decl)) + then + return + Present (Exception_Handlers + (Handled_Statement_Sequence + (Unit_Declaration_Node (Corresponding_Body (Decl))))); + else + -- If body is not available, assume the best, the check is + -- performed again when compiling enclosing package bodies. + + return False; + end if; + end Back_End_Cannot_Inline; + ----------------- -- Make_Inline -- ----------------- procedure Make_Inline (Subp : Entity_Id) is - Kind : Entity_Kind := Ekind (Subp); + Kind : constant Entity_Kind := Ekind (Subp); Inner_Subp : Entity_Id := Subp; begin if Etype (Subp) = Any_Type then return; + elsif Back_End_Cannot_Inline (Subp) then + Applies := True; -- Do not treat as an error. + return; + -- Here we have a candidate for inlining, but we must exclude -- derived operations. Otherwise we will end up trying to -- inline a phantom declaration, and the result would be to @@ -2741,10 +2933,7 @@ package body Sem_Prag is -- If subprogram is aliased (as for an instance) indicate -- that the renamed entity is inlined. - if Kind = E_Procedure - or else Kind = E_Function - or else Kind = E_Operator - then + if Is_Subprogram (Subp) then while Present (Alias (Inner_Subp)) loop Inner_Subp := Alias (Inner_Subp); end loop; @@ -2765,13 +2954,11 @@ package body Sem_Prag is -- the point of instantiation, to determine whether the -- body should be generated. - elsif Kind = E_Generic_Procedure - or else Kind = E_Generic_Function - then + elsif Is_Generic_Subprogram (Subp) then Set_Inline_Flags (Subp); Applies := True; - -- Literals are by definition inlined. + -- Literals are by definition inlined elsif Kind = E_Enumeration_Literal then null; @@ -2842,7 +3029,6 @@ package body Sem_Prag is Next (Assoc); end loop; - end Process_Inline; ---------------------------- @@ -2877,9 +3063,10 @@ package body Sem_Prag is for J in 1 .. SL loop C := Get_String_Char (S, J); - if not In_Character_Range (C) - or else Get_Character (C) = ' ' - or else Get_Character (C) = ',' + if Warn_On_Export_Import + and then (not In_Character_Range (C) + or else Get_Character (C) = ' ' + or else Get_Character (C) = ',') then Error_Msg_N ("?interface name contains illegal character", SN); @@ -2999,108 +3186,66 @@ package body Sem_Prag is ----------------------------------------- procedure Process_Interrupt_Or_Attach_Handler is - Arg1_X : constant Node_Id := Expression (Arg1); - Prot_Proc : constant Entity_Id := Entity (Arg1_X); - Prot_Type : constant Entity_Id := Scope (Prot_Proc); + Arg1_X : constant Node_Id := Expression (Arg1); + Handler_Proc : constant Entity_Id := Entity (Arg1_X); + Proc_Scope : constant Entity_Id := Scope (Handler_Proc); begin - Set_Is_Interrupt_Handler (Prot_Proc); + Set_Is_Interrupt_Handler (Handler_Proc); - if Prag_Id = Pragma_Interrupt_Handler - or Prag_Id = Pragma_Attach_Handler - then - Record_Rep_Item (Prot_Type, N); - end if; + -- If the pragma is not associated with a handler procedure + -- within a protected type, then it must be for a nonprotected + -- procedure for the AAMP target, in which case we don't + -- associate a representation item with the procedure's scope. + if Ekind (Proc_Scope) = E_Protected_Type then + if Prag_Id = Pragma_Interrupt_Handler + or Prag_Id = Pragma_Attach_Handler + then + Record_Rep_Item (Proc_Scope, N); + end if; + end if; end Process_Interrupt_Or_Attach_Handler; --------------------------------- -- Process_Suppress_Unsuppress -- --------------------------------- + -- Note: this procedure makes entries in the check suppress data + -- structures managed by Sem. See spec of package Sem for full + -- details on how we handle recording of check suppression. + procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is - C : Check_Id; - E_Id : Node_Id; - E : Entity_Id; - Effective : Boolean; + C : Check_Id; + E_Id : Node_Id; + E : Entity_Id; + + In_Package_Spec : constant Boolean := + (Ekind (Current_Scope) = E_Package + or else + Ekind (Current_Scope) = E_Generic_Package) + and then not In_Package_Body (Current_Scope); procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id); -- Used to suppress a single check on the given entity + -------------------------------- + -- Suppress_Unsuppress_Echeck -- + -------------------------------- + procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is - begin - -- First set appropriate suppress flags in the entity - - case C is - when Access_Check => - Effective := Suppress_Access_Checks (E); - Set_Suppress_Access_Checks (E, Suppress_Case); - - when Accessibility_Check => - Effective := Suppress_Accessibility_Checks (E); - Set_Suppress_Accessibility_Checks (E, Suppress_Case); - - when Discriminant_Check => - Effective := Suppress_Discriminant_Checks (E); - Set_Suppress_Discriminant_Checks (E, Suppress_Case); - - when Division_Check => - Effective := Suppress_Division_Checks (E); - Set_Suppress_Division_Checks (E, Suppress_Case); - - when Elaboration_Check => - Effective := Suppress_Elaboration_Checks (E); - Set_Suppress_Elaboration_Checks (E, Suppress_Case); - - when Index_Check => - Effective := Suppress_Index_Checks (E); - Set_Suppress_Index_Checks (E, Suppress_Case); - - when Length_Check => - Effective := Suppress_Length_Checks (E); - Set_Suppress_Length_Checks (E, Suppress_Case); - - when Overflow_Check => - Effective := Suppress_Overflow_Checks (E); - Set_Suppress_Overflow_Checks (E, Suppress_Case); - - when Range_Check => - Effective := Suppress_Range_Checks (E); - Set_Suppress_Range_Checks (E, Suppress_Case); - - when Storage_Check => - Effective := Suppress_Storage_Checks (E); - Set_Suppress_Storage_Checks (E, Suppress_Case); - - when Tag_Check => - Effective := Suppress_Tag_Checks (E); - Set_Suppress_Tag_Checks (E, Suppress_Case); - - when All_Checks => - Suppress_Unsuppress_Echeck (E, Access_Check); - Suppress_Unsuppress_Echeck (E, Accessibility_Check); - Suppress_Unsuppress_Echeck (E, Discriminant_Check); - Suppress_Unsuppress_Echeck (E, Division_Check); - Suppress_Unsuppress_Echeck (E, Elaboration_Check); - Suppress_Unsuppress_Echeck (E, Index_Check); - Suppress_Unsuppress_Echeck (E, Length_Check); - Suppress_Unsuppress_Echeck (E, Overflow_Check); - Suppress_Unsuppress_Echeck (E, Range_Check); - Suppress_Unsuppress_Echeck (E, Storage_Check); - Suppress_Unsuppress_Echeck (E, Tag_Check); - end case; + ESR : constant Entity_Check_Suppress_Record := + (Entity => E, + Check => C, + Suppress => Suppress_Case); - -- If the entity is not declared in the current scope, then we - -- make an entry in the Entity_Suppress table so that the flag - -- will be removed on exit. This entry is only made if the - -- suppress did something (i.e. the flag was not already set). + begin + Set_Checks_May_Be_Suppressed (E); - if Effective and then Scope (E) /= Current_Scope then - Entity_Suppress.Increment_Last; - Entity_Suppress.Table - (Entity_Suppress.Last).Entity := E; - Entity_Suppress.Table - (Entity_Suppress.Last).Check := C; + if In_Package_Spec then + Global_Entity_Suppress.Append (ESR); + else + Local_Entity_Suppress.Append (ESR); end if; -- If this is a first subtype, and the base type is distinct, @@ -3137,44 +3282,24 @@ package body Sem_Prag is end if; if Arg_Count = 1 then - case C is - when Access_Check => - Scope_Suppress.Access_Checks := Suppress_Case; - - when Accessibility_Check => - Scope_Suppress.Accessibility_Checks := Suppress_Case; - - when Discriminant_Check => - Scope_Suppress.Discriminant_Checks := Suppress_Case; - - when Division_Check => - Scope_Suppress.Division_Checks := Suppress_Case; - - when Elaboration_Check => - Scope_Suppress.Elaboration_Checks := Suppress_Case; - - when Index_Check => - Scope_Suppress.Index_Checks := Suppress_Case; - - when Length_Check => - Scope_Suppress.Length_Checks := Suppress_Case; - - when Overflow_Check => - Scope_Suppress.Overflow_Checks := Suppress_Case; - - when Range_Check => - Scope_Suppress.Range_Checks := Suppress_Case; - when Storage_Check => - Scope_Suppress.Storage_Checks := Suppress_Case; + -- Make an entry in the local scope suppress table. This is the + -- table that directly shows the current value of the scope + -- suppress check for any check id value. - when Tag_Check => - Scope_Suppress.Tag_Checks := Suppress_Case; + if C = All_Checks then + Scope_Suppress := (others => Suppress_Case); + else + Scope_Suppress (C) := Suppress_Case; + end if; - when All_Checks => - Scope_Suppress := (others => Suppress_Case); + -- Also make an entry in the Local_Entity_Suppress table. See + -- extended description in the package spec of Sem for details. - end case; + Local_Entity_Suppress.Append + ((Entity => Empty, + Check => C, + Suppress => Suppress_Case)); -- Case of two arguments present, where the check is -- suppressed for a specified entity (given as the second @@ -3194,34 +3319,48 @@ package body Sem_Prag is if E = Any_Id then return; - else - loop - Suppress_Unsuppress_Echeck (E, C); + end if; - if Is_Generic_Instance (E) - and then Is_Subprogram (E) - and then Present (Alias (E)) - then - Suppress_Unsuppress_Echeck (Alias (E), C); - end if; + -- Enforce RM 11.5(7) which requires that for a pragma that + -- appears within a package spec, the named entity must be + -- within the package spec. We allow the package name itself + -- to be mentioned since that makes sense, although it is not + -- strictly allowed by 11.5(7). - if C = Elaboration_Check and then Suppress_Case then - Set_Suppress_Elaboration_Warnings (E); - end if; + if In_Package_Spec + and then E /= Current_Scope + and then Scope (E) /= Current_Scope + then + Error_Pragma_Arg + ("entity in pragma% is not in package spec ('R'M 11.5(7))", + Arg2); + end if; - -- If we are within a package specification, the - -- pragma only applies to homonyms in the same scope. + -- Loop through homonyms. As noted below, in the case of a package + -- spec, only homonyms within the package spec are considered. - exit when No (Homonym (E)) - or else (Scope (Homonym (E)) /= Current_Scope - and then Ekind (Current_Scope) = E_Package - and then not In_Package_Body (Current_Scope)); + loop + Suppress_Unsuppress_Echeck (E, C); - E := Homonym (E); - end loop; - end if; - end if; + if Is_Generic_Instance (E) + and then Is_Subprogram (E) + and then Present (Alias (E)) + then + Suppress_Unsuppress_Echeck (Alias (E), C); + end if; + + -- Move to next homonym + E := Homonym (E); + exit when No (E); + + -- If we are within a package specification, the + -- pragma only applies to homonyms in the same scope. + + exit when In_Package_Spec + and then Scope (E) /= Current_Scope; + end loop; + end if; end Process_Suppress_Unsuppress; ------------------ @@ -3241,6 +3380,12 @@ package body Sem_Prag is Set_Is_Exported (E); + -- Generate a reference for entity explicitly, because the + -- identifier may be overloaded and name resolution will not + -- generate one. + + Generate_Reference (E, Arg); + -- Deal with exporting non-library level entity if not Is_Library_Level_Entity (E) then @@ -3255,14 +3400,25 @@ package body Sem_Prag is else Set_Is_Public (E); Set_Is_Statically_Allocated (E); + + if Warn_On_Export_Import then + Error_Msg_NE + ("?& has been made static as a result of Export", Arg, E); + Error_Msg_N + ("\this usage is non-standard and non-portable", Arg); + end if; end if; end if; - if Inside_A_Generic then + if Warn_On_Export_Import and then Is_Type (E) then Error_Msg_NE - ("all instances of& will have the same external name?", Arg, E); + ("exporting a type has no effect?", Arg, E); end if; + if Warn_On_Export_Import and Inside_A_Generic then + Error_Msg_NE + ("all instances of& will have the same external name?", Arg, E); + end if; end Set_Exported; ---------------------------------------------- @@ -3509,7 +3665,11 @@ package body Sem_Prag is begin if not Is_Pragma_Name (Chars (N)) then - Error_Pragma ("unrecognized pragma%!?"); + if Warn_On_Unrecognized_Pragma then + Error_Pragma ("unrecognized pragma%!?"); + else + raise Pragma_Exit; + end if; else Prag_Id := Get_Pragma_Id (Chars (N)); end if; @@ -3675,7 +3835,7 @@ package body Sem_Prag is Error_Pragma_Arg ("ambiguous argument for pragma%", Exp); else - Resolve (Exp, Etype (Exp)); + Resolve (Exp); end if; Next (Arg); @@ -3912,7 +4072,6 @@ package body Sem_Prag is else Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1); end if; - end Asynchronous; ------------ @@ -4006,9 +4165,33 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_No_Identifiers; Check_Arg_Count (2); - Check_Interrupt_Or_Attach_Handler; - Analyze_And_Resolve (Expression (Arg2), RTE (RE_Interrupt_Id)); - Process_Interrupt_Or_Attach_Handler; + + if No_Run_Time_Mode then + Error_Msg_CRT ("Attach_Handler pragma", N); + else + Check_Interrupt_Or_Attach_Handler; + + -- The expression that designates the attribute may + -- depend on a discriminant, and is therefore a per- + -- object expression, to be expanded in the init proc. + -- If expansion is enabled, perform semantic checks + -- on a copy only. + + if Expander_Active then + declare + Temp : Node_Id := New_Copy_Tree (Expression (Arg2)); + begin + Set_Parent (Temp, N); + Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID)); + end; + + else + Analyze (Expression (Arg2)); + Resolve (Expression (Arg2), RTE (RE_Interrupt_ID)); + end if; + + Process_Interrupt_Or_Attach_Handler; + end if; -------------------- -- C_Pass_By_Copy -- @@ -4070,6 +4253,55 @@ package body Sem_Prag is -- Processing for this pragma is shared with Psect_Object + -------------------------- + -- Compile_Time_Warning -- + -------------------------- + + -- pragma Compile_Time_Warning + -- (boolean_EXPRESSION, static_string_EXPRESSION); + + when Pragma_Compile_Time_Warning => Compile_Time_Warning : declare + Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1); + + begin + GNAT_Pragma; + Check_Arg_Count (2); + Check_No_Identifiers; + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + Analyze_And_Resolve (Arg1x, Standard_Boolean); + + if Compile_Time_Known_Value (Arg1x) then + if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then + String_To_Name_Buffer (Strval (Get_Pragma_Arg (Arg2))); + Add_Char_To_Name_Buffer ('?'); + + declare + Msg : String (1 .. Name_Len) := + Name_Buffer (1 .. Name_Len); + + B : Natural; + + begin + -- This loop looks for multiple lines separated by + -- ASCII.LF and breaks them into continuation error + -- messages marked with the usual back slash. + + B := 1; + for S in 2 .. Msg'Length - 1 loop + if Msg (S) = ASCII.LF then + Msg (S) := '?'; + Error_Msg_N (Msg (B .. S), Arg1); + B := S; + Msg (B) := '\'; + end if; + end loop; + + Error_Msg_N (Msg (B .. Msg'Length), Arg1); + end; + end if; + end if; + end Compile_Time_Warning; + ---------------------------- -- Complex_Representation -- ---------------------------- @@ -4132,7 +4364,7 @@ package body Sem_Prag is when Pragma_Component_Alignment => Component_AlignmentP : declare Args : Args_List (1 .. 2); - Names : Name_List (1 .. 2) := ( + Names : constant Name_List (1 .. 2) := ( Name_Form, Name_Name); @@ -4364,8 +4596,8 @@ package body Sem_Prag is -- Since a CPP type has no direct link to its associated tag -- most tags checks cannot be performed - Set_Suppress_Tag_Checks (Typ); - Set_Suppress_Tag_Checks (Class_Wide_Type (Typ)); + Set_Kill_Tag_Checks (Typ); + Set_Kill_Tag_Checks (Class_Wide_Type (Typ)); -- Get rid of the _tag component when there was one. -- It is only useful for regular tagged types @@ -4539,9 +4771,10 @@ package body Sem_Prag is Analyze_And_Resolve (Arg, Any_Integer); if not Is_Static_Expression (Arg) then - Error_Pragma_Arg - ("third argument of pragma% must be a static expression", + Flag_Non_Static_Expr + ("third argument of pragma CPP_Virtual must be static!", Arg3); + raise Pragma_Exit; else V := Expr_Value (Expression (Arg3)); @@ -4651,8 +4884,10 @@ package body Sem_Prag is Analyze_And_Resolve (Arg, Any_Integer); if not Is_Static_Expression (Arg) then - Error_Pragma_Arg - ("entry count for pragma% must be a static expression", Arg3); + Flag_Non_Static_Expr + ("entry count for pragma CPP_Vtable must be a static " & + "expression!", Arg3); + raise Pragma_Exit; else V := Expr_Value (Expression (Arg3)); @@ -4664,7 +4899,6 @@ package body Sem_Prag is Set_DT_Entry_Count (DTC, V); end if; end if; - end CPP_Vtable; ----------- @@ -4849,6 +5083,16 @@ package body Sem_Prag is Next (Arg); end loop Outer; + + -- Give a warning if operating in static mode with -gnatwl + -- (elaboration warnings eanbled) switch set. + + if Elab_Warnings and not Dynamic_Elaboration_Checks then + Error_Msg_N + ("?use of pragma Elaborate may not be safe", N); + Error_Msg_N + ("?use pragma Elaborate_All instead if possible", N); + end if; end Elaborate; ------------------- @@ -4918,6 +5162,7 @@ package body Sem_Prag is end loop Innr; if Citem = N then + Set_Error_Posted (N); Error_Pragma_Arg ("argument of pragma% is not with'ed unit", Arg); end if; @@ -5009,7 +5254,7 @@ package body Sem_Prag is when Pragma_Eliminate => Eliminate : declare Args : Args_List (1 .. 5); - Names : Name_List (1 .. 5) := ( + Names : constant Name_List (1 .. 5) := ( Name_Unit_Name, Name_Entity, Name_Parameter_Types, @@ -5049,6 +5294,15 @@ package body Sem_Prag is Homonym_Number); end Eliminate; + -------------------------- + -- Explicit_Overriding -- + -------------------------- + + when Pragma_Explicit_Overriding => + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + Explicit_Overriding := True; + ------------ -- Export -- ------------ @@ -5089,7 +5343,7 @@ package body Sem_Prag is when Pragma_Export_Exception => Export_Exception : declare Args : Args_List (1 .. 4); - Names : Name_List (1 .. 4) := ( + Names : constant Name_List (1 .. 4) := ( Name_Internal, Name_External, Name_Form, @@ -5115,7 +5369,6 @@ package body Sem_Prag is if not Is_VMS_Exception (Entity (Internal)) then Set_Exported (Entity (Internal), Internal); end if; - end Export_Exception; --------------------- @@ -5126,13 +5379,39 @@ package body Sem_Prag is -- [Internal =>] LOCAL_NAME, -- [, [External =>] EXTERNAL_SYMBOL,] -- [, [Parameter_Types =>] (PARAMETER_TYPES)] - -- [, [Result_Type =>] SUBTYPE_MARK] + -- [, [Result_Type =>] TYPE_DESIGNATOR] -- [, [Mechanism =>] MECHANISM] -- [, [Result_Mechanism =>] MECHANISM_NAME]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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); - Names : Name_List (1 .. 6) := ( + Names : constant Name_List (1 .. 6) := ( Name_Internal, Name_External, Name_Parameter_Types, @@ -5168,9 +5447,35 @@ package body Sem_Prag is -- [, [External =>] EXTERNAL_SYMBOL] -- [, [Size =>] EXTERNAL_SYMBOL]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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); - Names : Name_List (1 .. 3) := ( + Names : constant Name_List (1 .. 3) := ( Name_Internal, Name_External, Name_Size); @@ -5198,9 +5503,35 @@ package body Sem_Prag is -- [, [Parameter_Types =>] (PARAMETER_TYPES)] -- [, [Mechanism =>] MECHANISM]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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); - Names : Name_List (1 .. 4) := ( + Names : constant Name_List (1 .. 4) := ( Name_Internal, Name_External, Name_Parameter_Types, @@ -5221,6 +5552,24 @@ package body Sem_Prag is Arg_Mechanism => Mechanism); end Export_Procedure; + ------------------ + -- Export_Value -- + ------------------ + + -- pragma Export_Value ( + -- [Value =>] static_integer_EXPRESSION, + -- [Link_Name =>] static_string_EXPRESSION); + + when Pragma_Export_Value => + GNAT_Pragma; + Check_Arg_Count (2); + + Check_Optional_Identifier (Arg1, Name_Value); + Check_Arg_Is_Static_Expression (Arg1, Any_Integer); + + Check_Optional_Identifier (Arg2, Name_Link_Name); + Check_Arg_Is_Static_Expression (Arg2, Standard_String); + ----------------------------- -- Export_Valued_Procedure -- ----------------------------- @@ -5231,10 +5580,36 @@ package body Sem_Prag is -- [, [Parameter_Types =>] (PARAMETER_TYPES)] -- [, [Mechanism =>] MECHANISM]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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 Args : Args_List (1 .. 4); - Names : Name_List (1 .. 4) := ( + Names : constant Name_List (1 .. 4) := ( Name_Internal, Name_External, Name_Parameter_Types, @@ -5286,6 +5661,10 @@ package body Sem_Prag is else System_Extend_Pragma_Arg := Arg1; + + if not GNAT_Mode then + System_Extend_Unit := Arg1; + end if; end if; else Error_Pragma ("incorrect name for pragma%, must be Aux_xxx"); @@ -5387,8 +5766,8 @@ package body Sem_Prag is -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME); when Pragma_Finalize_Storage_Only => Finalize_Storage : declare - Assoc : Node_Id := Arg1; - Type_Id : Node_Id := Expression (Assoc); + Assoc : constant Node_Id := Arg1; + Type_Id : constant Node_Id := Expression (Assoc); Typ : Entity_Id; begin @@ -5551,16 +5930,6 @@ package body Sem_Prag is Str := Expr_Value_S (Expression (Arg1)); - -- For pragma Ident, preserve DEC compatibility by limiting - -- the length to 31 characters. - - if Prag_Id = Pragma_Ident - and then String_Length (Strval (Str)) > 31 - then - Error_Pragma_Arg - ("argument for pragma% is too long, maximum is 31", Arg1); - end if; - declare CS : Node_Id; GP : Node_Id; @@ -5591,7 +5960,7 @@ package body Sem_Prag is -- For Comment, we concatenate the string, unless we -- want to preserve the tree structure for ASIS. - elsif not Tree_Output then + elsif not ASIS_Mode then Start_String (Strval (CS)); Store_String_Char (' '); Store_String_Chars (Strval (Str)); @@ -5668,7 +6037,7 @@ package body Sem_Prag is when Pragma_Import_Exception => Import_Exception : declare Args : Args_List (1 .. 4); - Names : Name_List (1 .. 4) := ( + Names : constant Name_List (1 .. 4) := ( Name_Internal, Name_External, Name_Form, @@ -5711,9 +6080,35 @@ package body Sem_Prag is -- [, [Result_Mechanism =>] MECHANISM_NAME] -- [, [First_Optional_Parameter =>] IDENTIFIER]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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 : Name_List (1 .. 7) := ( + Names : constant Name_List (1 .. 7) := ( Name_Internal, Name_External, Name_Parameter_Types, @@ -5752,9 +6147,13 @@ package body Sem_Prag is -- [, [External =>] EXTERNAL_SYMBOL] -- [, [Size =>] EXTERNAL_SYMBOL]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + when Pragma_Import_Object => Import_Object : declare Args : Args_List (1 .. 3); - Names : Name_List (1 .. 3) := ( + Names : constant Name_List (1 .. 3) := ( Name_Internal, Name_External, Name_Size); @@ -5783,9 +6182,35 @@ package body Sem_Prag is -- [, [Mechanism =>] MECHANISM] -- [, [First_Optional_Parameter =>] IDENTIFIER]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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 : Name_List (1 .. 5) := ( + Names : constant Name_List (1 .. 5) := ( Name_Internal, Name_External, Name_Parameter_Types, @@ -5820,10 +6245,36 @@ package body Sem_Prag is -- [, [Mechanism =>] MECHANISM] -- [, [First_Optional_Parameter =>] IDENTIFIER]); + -- EXTERNAL_SYMBOL ::= + -- IDENTIFIER + -- | static_string_EXPRESSION + + -- PARAMETER_TYPES ::= + -- null + -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@} + + -- TYPE_DESIGNATOR ::= + -- subtype_NAME + -- | subtype_Name ' Access + + -- MECHANISM ::= + -- MECHANISM_NAME + -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@}) + + -- MECHANISM_ASSOCIATION ::= + -- [formal_parameter_NAME =>] MECHANISM_NAME + + -- 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 : Name_List (1 .. 5) := ( + Names : constant Name_List (1 .. 5) := ( Name_Internal, Name_External, Name_Parameter_Types, @@ -5857,8 +6308,12 @@ package body Sem_Prag is GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Init_Or_Norm_Scalars := True; - Initialize_Scalars := True; + Check_Restriction (No_Initialize_Scalars, N); + + if not Restrictions (No_Initialize_Scalars) then + Init_Or_Norm_Scalars := True; + Initialize_Scalars := True; + end if; ------------ -- Inline -- @@ -5873,14 +6328,16 @@ package body Sem_Prag is if Inline_Active then Process_Inline (True); - -- Pragma is active in a predefined file in no run time mode + -- Pragma is active in a predefined file in config run time mode - elsif No_Run_Time + elsif Configurable_Run_Time_Mode and then Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then Process_Inline (True); + -- Otherwise inlining is not active + else Process_Inline (False); end if; @@ -6058,8 +6515,13 @@ package body Sem_Prag is Check_Ada_83_Warning; Check_Arg_Count (1); Check_No_Identifiers; - Check_Interrupt_Or_Attach_Handler; - Process_Interrupt_Or_Attach_Handler; + + if No_Run_Time_Mode then + Error_Msg_CRT ("Interrupt_Handler pragma", N); + else + Check_Interrupt_Or_Attach_Handler; + Process_Interrupt_Or_Attach_Handler; + end if; ------------------------ -- Interrupt_Priority -- @@ -6079,13 +6541,11 @@ package body Sem_Prag is Check_Arg_Count (1); Check_No_Identifiers; - -- Set In_Default_Expression for per-object case??? + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. - Analyze_And_Resolve (Arg, Standard_Integer); - if Expander_Active then - Rewrite (Arg, - Convert_To (RTE (RE_Interrupt_Priority), Arg)); - end if; + Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority)); end if; if Nkind (P) /= N_Task_Definition @@ -6103,6 +6563,134 @@ package body Sem_Prag is end if; end Interrupt_Priority; + --------------------- + -- Interrupt_State -- + --------------------- + + -- pragma Interrupt_State ( + -- [Name =>] INTERRUPT_ID, + -- [State =>] INTERRUPT_STATE); + + -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION + -- INTERRUPT_STATE => System | Runtime | User + + -- Note: if the interrupt id is given as an identifier, then + -- it must be one of the identifiers in Ada.Interrupts.Names. + -- Otherwise it is given as a static integer expression which + -- must be in the range of Ada.Interrupts.Interrupt_ID. + + when Pragma_Interrupt_State => Interrupt_State : declare + + Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID); + -- This is the entity Ada.Interrupts.Interrupt_ID; + + State_Type : Character; + -- Set to 's'/'r'/'u' for System/Runtime/User + + IST_Num : Pos; + -- Index to entry in Interrupt_States table + + Int_Val : Uint; + -- Value of interrupt + + Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1); + -- The first argument to the pragma + + Int_Ent : Entity_Id; + -- Interrupt entity in Ada.Interrupts.Names + + begin + GNAT_Pragma; + Check_Arg_Count (2); + + Check_Optional_Identifier (Arg1, Name_Name); + Check_Optional_Identifier (Arg2, "state"); + Check_Arg_Is_Identifier (Arg2); + + -- First argument is identifier + + if Nkind (Arg1X) = N_Identifier then + + -- Search list of names in Ada.Interrupts.Names + + Int_Ent := First_Entity (RTE (RE_Names)); + loop + if No (Int_Ent) then + Error_Pragma_Arg ("invalid interrupt name", Arg1); + + elsif Chars (Int_Ent) = Chars (Arg1X) then + Int_Val := Expr_Value (Constant_Value (Int_Ent)); + exit; + end if; + + Next_Entity (Int_Ent); + end loop; + + -- First argument is not an identifier, so it must be a + -- static expression of type Ada.Interrupts.Interrupt_ID. + + else + Check_Arg_Is_Static_Expression (Arg1, Any_Integer); + Int_Val := Expr_Value (Arg1X); + + if Int_Val < Expr_Value (Type_Low_Bound (Int_Id)) + or else + Int_Val > Expr_Value (Type_High_Bound (Int_Id)) + then + Error_Pragma_Arg + ("value not in range of type " & + """Ada.Interrupts.Interrupt_'I'D""", Arg1); + end if; + end if; + + -- Check OK state + + case Chars (Get_Pragma_Arg (Arg2)) is + when Name_Runtime => State_Type := 'r'; + when Name_System => State_Type := 's'; + when Name_User => State_Type := 'u'; + + when others => + Error_Pragma_Arg ("invalid interrupt state", Arg2); + end case; + + -- Check if entry is already stored + + IST_Num := Interrupt_States.First; + loop + -- If entry not found, add it + + if IST_Num > Interrupt_States.Last then + Interrupt_States.Append + ((Interrupt_Number => UI_To_Int (Int_Val), + Interrupt_State => State_Type, + Pragma_Loc => Loc)); + exit; + + -- Case of entry for the same entry + + elsif Int_Val = Interrupt_States.Table (IST_Num). + Interrupt_Number + then + -- If state matches, done, no need to make redundant entry + + exit when + State_Type = Interrupt_States.Table (IST_Num). + Interrupt_State; + + -- Otherwise if state does not match, error + + Error_Msg_Sloc := + Interrupt_States.Table (IST_Num).Pragma_Loc; + Error_Pragma_Arg + ("state conflicts with that given at #", Arg2); + exit; + end if; + + IST_Num := IST_Num + 1; + end loop; + end Interrupt_State; + ---------------------- -- Java_Constructor -- ---------------------- @@ -6217,6 +6805,38 @@ package body Sem_Prag is end if; end Java_Interface; + ---------------- + -- Keep_Names -- + ---------------- + + -- pragma Keep_Names ([On => ] local_NAME); + + when Pragma_Keep_Names => Keep_Names : declare + Arg : Node_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Optional_Identifier (Arg1, Name_On); + Check_Arg_Is_Local_Name (Arg1); + + Arg := Expression (Arg1); + Analyze (Arg); + + if Etype (Arg) = Any_Type then + return; + end if; + + if not Is_Entity_Name (Arg) + or else Ekind (Entity (Arg)) /= E_Enumeration_Type + then + Error_Pragma_Arg + ("pragma% requires a local enumeration type", Arg1); + end if; + + Set_Discard_Names (Entity (Arg), False); + end Keep_Names; + ------------- -- License -- ------------- @@ -6287,9 +6907,8 @@ package body Sem_Prag is C : constant Char_Code := Get_Char_Code (' '); S : constant String_Id := Strval (Expr_Value_S (Expression (Arg))); - + L : constant Nat := String_Length (S); F : Nat := 1; - L : Nat := String_Length (S); procedure Skip_Spaces; -- Advance F past any spaces @@ -6456,9 +7075,16 @@ package body Sem_Prag is 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; - Locking_Policy_Sloc := Loc; + + if Locking_Policy_Sloc /= System_Location then + Locking_Policy_Sloc := Loc; + end if; end if; end; @@ -6563,7 +7189,7 @@ package body Sem_Prag is when Pragma_Main => Main : declare Args : Args_List (1 .. 3); - Names : Name_List (1 .. 3) := ( + Names : constant Name_List (1 .. 3) := ( Name_Stack_Size, Name_Task_Stack_Size_Default, Name_Time_Slicing_Enabled); @@ -6610,7 +7236,7 @@ package body Sem_Prag is when Pragma_Main_Storage => Main_Storage : declare Args : Args_List (1 .. 2); - Names : Name_List (1 .. 2) := ( + Names : constant Name_List (1 .. 2) := ( Name_Working_Storage, Name_Top_Guard); @@ -6662,7 +7288,7 @@ package body Sem_Prag is -- pragma No_Return (procedure_LOCAL_NAME); - when Pragma_No_Return => declare + when Pragma_No_Return => No_Return : declare Id : Node_Id; E : Entity_Id; Found : Boolean; @@ -6702,7 +7328,32 @@ package body Sem_Prag is if not Found then Error_Pragma ("no procedures found for pragma%"); end if; - end; + end No_Return; + + ----------------- + -- Obsolescent -- + ----------------- + + -- pragma Obsolescent [(static_string_EXPRESSION)]; + + when Pragma_Obsolescent => Obsolescent : declare + begin + GNAT_Pragma; + Check_At_Most_N_Arguments (1); + Check_No_Identifiers; + + if Arg_Count = 1 then + Check_Arg_Is_Static_Expression (Arg1, Standard_String); + end if; + + if No (Prev (N)) + or else (Nkind (Prev (N))) /= N_Subprogram_Declaration + then + Error_Pragma + ("pragma% misplaced, must immediately " & + "follow subprogram spec"); + end if; + end Obsolescent; ----------------- -- No_Run_Time -- @@ -6710,11 +7361,24 @@ package body Sem_Prag is -- pragma No_Run_Time + -- Note: this pragma is retained for backwards compatibiltiy. + -- See body of Rtsfind for full details on its handling. + when Pragma_No_Run_Time => GNAT_Pragma; Check_Valid_Configuration_Pragma; Check_Arg_Count (0); - Set_No_Run_Time_Mode; + + No_Run_Time_Mode := True; + Configurable_Run_Time_Mode := True; + + if Ttypes.System_Word_Size = 32 then + Duration_32_Bits_On_Target := True; + end if; + + Restrictions (No_Finalization) := True; + Restrictions (No_Exception_Handlers) := True; + Restriction_Parameters (Max_Tasks) := Uint_0; ----------------------- -- Normalize_Scalars -- @@ -6744,6 +7408,25 @@ package body Sem_Prag is Check_Arg_Count (1); Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off); + ------------------------- + -- Optional_Overriding -- + ------------------------- + + -- These pragmas are treated as part of the previous subprogram + -- declaration, and analyzed immediately after it (see sem_ch6, + -- Check_Overriding_Operation). If the pragma has not been analyzed + -- yet, it appears in the wrong place. + + when Pragma_Optional_Overriding => + Error_Msg_N ("pragma must appear immediately after subprogram", N); + + ---------------- + -- Overriding -- + ---------------- + + when Pragma_Overriding => + Error_Msg_N ("pragma must appear immediately after subprogram", N); + ---------- -- Pack -- ---------- @@ -6751,7 +7434,7 @@ package body Sem_Prag is -- pragma Pack (first_subtype_LOCAL_NAME); when Pragma_Pack => Pack : declare - Assoc : Node_Id := Arg1; + Assoc : constant Node_Id := Arg1; Type_Id : Node_Id; Typ : Entity_Id; @@ -6790,7 +7473,6 @@ package body Sem_Prag is -- till that point (i.e. right now it may be unfrozen). elsif Is_Array_Type (Typ) then - if Has_Aliased_Components (Base_Type (Typ)) then Error_Pragma ("pragma% ignored, cannot pack aliased components?"); @@ -6807,7 +7489,7 @@ package body Sem_Prag is -- Record type. For record types, the pack is always effective - else -- Is_Record_Type (Typ) + else pragma Assert (Is_Record_Type (Typ)); if not Rep_Item_Too_Late (Typ, N) then Set_Has_Pragma_Pack (Base_Type (Typ)); Set_Is_Packed (Base_Type (Typ)); @@ -6862,6 +7544,104 @@ package body Sem_Prag is Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off); Polling_Required := (Chars (Expression (Arg1)) = Name_On); + --------------------- + -- Persistent_Data -- + --------------------- + + when Pragma_Persistent_Data => declare + Ent : Entity_Id; + + begin + -- Register the pragma as applying to the compilation unit. + -- Individual Persistent_Object pragmas for relevant objects + -- are generated the end of the compilation. + + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + Check_Arg_Count (0); + Ent := Find_Lib_Unit_Name; + Set_Is_Preelaborated (Ent); + end; + + ------------------------ + -- Persistent_Object -- + ------------------------ + + when Pragma_Persistent_Object => declare + Decl : Node_Id; + Ent : Entity_Id; + MA : Node_Id; + Str : String_Id; + + begin + GNAT_Pragma; + Check_Arg_Count (1); + Check_Arg_Is_Library_Level_Local_Name (Arg1); + if not Is_Entity_Name (Expression (Arg1)) + or else + (Ekind (Entity (Expression (Arg1))) /= E_Variable + and then Ekind (Entity (Expression (Arg1))) /= E_Constant) + then + Error_Pragma_Arg ("pragma only applies to objects", Arg1); + end if; + + Ent := Entity (Expression (Arg1)); + Decl := Parent (Ent); + + if Nkind (Decl) /= N_Object_Declaration then + return; + end if; + + -- Placement of the object depends on whether there is + -- an initial value or none. If the No_Initialization flag + -- is set, the initialization has been transformed into + -- assignments, which is disallowed elaboration code. + + if No_Initialization (Decl) then + Error_Msg_N + ("initialization for persistent object" + & "must be static expression", Decl); + return; + end if; + + if No (Expression (Decl)) then + Start_String; + Store_String_Chars ("section ("".persistent.bss"")"); + Str := End_String; + + else + if not Is_OK_Static_Expression (Expression (Decl)) then + Flag_Non_Static_Expr + ("initialization for persistent object" + & "must be static expression!", Expression (Decl)); + return; + end if; + + Start_String; + Store_String_Chars ("section ("".persistent.data"")"); + Str := End_String; + end if; + + MA := + Make_Pragma + (Sloc (N), + Name_Machine_Attribute, + New_List + (Make_Pragma_Argument_Association + (Sloc => Sloc (Arg1), + Expression => New_Occurrence_Of (Ent, Sloc (Ent))), + Make_Pragma_Argument_Association + (Sloc => Sloc (Arg1), + Expression => + Make_String_Literal + (Sloc => Sloc (Arg1), + Strval => Str)))); + + Insert_After (N, MA); + Analyze (MA); + Set_Has_Gigi_Rep_Item (Ent); + end; + ------------------ -- Preelaborate -- ------------------ @@ -6871,9 +7651,9 @@ package body Sem_Prag is -- Set the flag Is_Preelaborated of program unit name entity when Pragma_Preelaborate => Preelaborate : declare + Pa : constant Node_Id := Parent (N); + Pk : constant Node_Kind := Nkind (Pa); Ent : Entity_Id; - Pa : Node_Id := Parent (N); - Pk : Node_Kind := Nkind (Pa); begin Check_Ada_83_Warning; @@ -6913,23 +7693,20 @@ package body Sem_Prag is Check_No_Identifiers; Check_Arg_Count (1); - Arg := Expression (Arg1); - Analyze_And_Resolve (Arg, Standard_Integer); - - if not Is_Static_Expression (Arg) then - Check_Restriction (Static_Priorities, Arg); - end if; - -- Subprogram case if Nkind (P) = N_Subprogram_Body then Check_In_Main_Program; + Arg := Expression (Arg1); + Analyze_And_Resolve (Arg, Standard_Integer); + -- Must be static if not Is_Static_Expression (Arg) then - Error_Pragma_Arg - ("main subprogram priority is not static", Arg1); + Flag_Non_Static_Expr + ("main subprogram priority is not static!", Arg); + raise Pragma_Exit; -- If constraint error, then we already signalled an error @@ -6962,9 +7739,16 @@ package body Sem_Prag is or else Nkind (P) = N_Task_Definition then - if Expander_Active then - Rewrite (Arg, - Convert_To (RTE (RE_Any_Priority), Arg)); + Arg := Expression (Arg1); + + -- The expression must be analyzed in the special manner + -- described in "Handling of Default and Per-Object + -- Expressions" in sem.ads. + + Analyze_Per_Use_Expression (Arg, Standard_Integer); + + if not Is_Static_Expression (Arg) then + Check_Restriction (Static_Priorities, Arg); end if; -- Anything else is incorrect @@ -7014,7 +7798,7 @@ package body Sem_Prag is when Pragma_Psect_Object | Pragma_Common_Object => Psect_Object : declare Args : Args_List (1 .. 3); - Names : Name_List (1 .. 3) := ( + Names : constant Name_List (1 .. 3) := ( Name_Internal, Name_External, Name_Size); @@ -7041,7 +7825,7 @@ package body Sem_Prag is -------------------- procedure Check_Too_Long (Arg : Node_Id) is - X : Node_Id := Original_Node (Arg); + X : constant Node_Id := Original_Node (Arg); begin if Nkind (X) /= N_String_Literal @@ -7122,6 +7906,7 @@ package body Sem_Prag is if Ekind (Ent) = E_Component and then Nkind (Decl) = N_Component_Declaration and then Present (Expression (Decl)) + and then Warn_On_Export_Import then Error_Msg_N ("?object for pragma % has defaults", R_Internal); @@ -7220,6 +8005,7 @@ package body Sem_Prag is (Make_Pragma_Argument_Association (Sloc => Sloc (R_Internal), Expression => R_Internal), + Make_Pragma_Argument_Association (Sloc => Sloc (R_External), Expression => @@ -7243,6 +8029,7 @@ package body Sem_Prag is (Make_Pragma_Argument_Association (Sloc => Sloc (R_Internal), Expression => R_Internal), + Make_Pragma_Argument_Association (Sloc => Sloc (R_External), Expression => @@ -7298,20 +8085,26 @@ package body Sem_Prag is -- Loop through homonyms (overloadings) of referenced entity E := Entity (E_Id); - while Present (E) loop - Def_Id := Get_Base_Subprogram (E); - if Ekind (Def_Id) /= E_Function - and then Ekind (Def_Id) /= E_Generic_Function - and then Ekind (Def_Id) /= E_Operator - then - Error_Pragma_Arg ("pragma% requires a function name", Arg1); - end if; + if Present (E) then + loop + Def_Id := Get_Base_Subprogram (E); - Set_Is_Pure (Def_Id); - Set_Has_Pragma_Pure_Function (Def_Id); - E := Homonym (E); - end loop; + if Ekind (Def_Id) /= E_Function + and then Ekind (Def_Id) /= E_Generic_Function + and then Ekind (Def_Id) /= E_Operator + then + Error_Pragma_Arg + ("pragma% requires a function name", Arg1); + end if; + + Set_Is_Pure (Def_Id); + Set_Has_Pragma_Pure_Function (Def_Id); + + E := Homonym (E); + exit when No (E) or else Scope (E) /= Current_Scope; + end loop; + end if; end Pure_Function; -------------------- @@ -7337,9 +8130,16 @@ package body Sem_Prag is then Error_Msg_Sloc := Queuing_Policy_Sloc; Error_Pragma ("queuing policy incompatible with policy#"); + + -- Set new policy, but always preserve System_Location since + -- we like the error message with the run time name. + else Queuing_Policy := QP; - Queuing_Policy_Sloc := Loc; + + if Queuing_Policy_Sloc /= System_Location then + Queuing_Policy_Sloc := Loc; + end if; end if; end; @@ -7418,21 +8218,25 @@ package body Sem_Prag is -- Ravenscar -- --------------- + -- pragma Ravenscar; + when Pragma_Ravenscar => GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Set_Ravenscar; + Set_Ravenscar (N); ------------------------- -- Restricted_Run_Time -- ------------------------- + -- pragma Restricted_Run_Time; + when Pragma_Restricted_Run_Time => GNAT_Pragma; Check_Arg_Count (0); Check_Valid_Configuration_Pragma; - Set_Restricted_Profile; + Set_Restricted_Profile (N); ------------------ -- Restrictions -- @@ -7458,7 +8262,6 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Arg := Arg1; - while Present (Arg) loop Id := Chars (Arg); Expr := Expression (Arg); @@ -7486,7 +8289,13 @@ package body Sem_Prag is end if; Restrictions (R_Id) := True; - Restrictions_Loc (R_Id) := Sloc (N); + + -- Set location, but preserve location of system + -- restriction for nice error msg with run time name + + if Restrictions_Loc (R_Id) /= System_Location then + Restrictions_Loc (R_Id) := Sloc (N); + end if; -- Record the restriction if we are in the main unit, -- or in the extended main unit. The reason that we @@ -7523,12 +8332,16 @@ package body Sem_Prag is Error_Pragma_Arg ("invalid restriction parameter identifier", Arg); - elsif not Is_OK_Static_Expression (Expr) - or else not Is_Integer_Type (Etype (Expr)) + elsif not Is_OK_Static_Expression (Expr) then + Flag_Non_Static_Expr + ("value must be static expression!", Expr); + raise Pragma_Exit; + + elsif not Is_Integer_Type (Etype (Expr)) or else Expr_Value (Expr) < 0 then Error_Pragma_Arg - ("value must be non-negative static integer", Arg); + ("value must be non-negative integer", Arg); -- Restriction pragma is active @@ -7540,7 +8353,7 @@ package body Sem_Prag is if Restriction_Parameters (RP_Id) = No_Uint or else Val < Restriction_Parameters (RP_Id) then - Restriction_Parameters (RP_Id) := Expr_Value (Expr); + Restriction_Parameters (RP_Id) := Val; Restriction_Parameters_Loc (RP_Id) := Sloc (N); end if; end if; @@ -7550,6 +8363,56 @@ package body Sem_Prag is end loop; end Restrictions_Pragma; + -------------------------- + -- Restriction_Warnings -- + -------------------------- + + -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION}); + + -- RESTRICTION ::= restriction_IDENTIFIER + + when Pragma_Restriction_Warnings => Restriction_Warn : declare + Arg : Node_Id; + R_Id : Restriction_Id; + Expr : Node_Id; + + begin + GNAT_Pragma; + Check_At_Least_N_Arguments (1); + Check_Valid_Configuration_Pragma; + Check_No_Identifiers; + + Arg := Arg1; + while Present (Arg) loop + Expr := Expression (Arg); + + if Nkind (Expr) /= N_Identifier then + Error_Pragma_Arg + ("invalid form for restriction", Arg); + + else + R_Id := Get_Restriction_Id (Chars (Expr)); + + if R_Id = Not_A_Restriction_Id then + Error_Pragma_Arg + ("invalid restriction identifier", Arg); + + -- Restriction is active + + else + if Implementation_Restriction (R_Id) then + Check_Restriction + (No_Implementation_Restrictions, Arg); + end if; + + Restriction_Warnings (R_Id) := True; + end if; + end if; + + Next (Arg); + end loop; + end Restriction_Warn; + ---------------- -- Reviewable -- ---------------- @@ -7633,6 +8496,40 @@ package body Sem_Prag is GNAT_Pragma; Check_Valid_Configuration_Pragma; + ------------------------------ + -- Source_File_Name_Project -- + ------------------------------ + + -- pragma Source_File_Name_Project ( + -- [UNIT_NAME =>] unit_NAME, + -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL); + + -- No processing here. Processing was completed during parsing, + -- since we need to have file names set as early as possible. + -- Units are loaded well before semantic processing starts. + + -- The only processing we defer to this point is the check + -- for correct placement. + + when Pragma_Source_File_Name_Project => + GNAT_Pragma; + Check_Valid_Configuration_Pragma; + + -- Check that a pragma Source_File_Name_Project is used only + -- in a configuration pragmas file. + -- Pragmas Source_File_Name_Project should only be generated + -- by the Project Manager in configuration pragmas files. + + -- This is really an ugly test. It seems to depend on some + -- accidental and undocumented property. At the very least + -- it needs to be documented, but it would be better to have + -- a clean way of testing if we are in a configuration file??? + + if Present (Parent (N)) then + Error_Pragma + ("pragma% can only appear in a configuration pragmas file"); + end if; + ---------------------- -- Source_Reference -- ---------------------- @@ -7652,20 +8549,23 @@ package body Sem_Prag is -- pragma Storage_Size (EXPRESSION); when Pragma_Storage_Size => Storage_Size : declare - P : constant Node_Id := Parent (N); - X : Node_Id; + P : constant Node_Id := Parent (N); + Arg : Node_Id; begin Check_No_Identifiers; Check_Arg_Count (1); - -- Set In_Default_Expression for per-object case??? + -- The expression must be analyzed in the special manner + -- described in "Handling of Default Expressions" in sem.ads. - X := Expression (Arg1); - Analyze_And_Resolve (X, Any_Integer); + -- Set In_Default_Expression for per-object case ??? + + Arg := Expression (Arg1); + Analyze_Per_Use_Expression (Arg, Any_Integer); - if not Is_Static_Expression (X) then - Check_Restriction (Static_Storage_Size, X); + if not Is_Static_Expression (Arg) then + Check_Restriction (Static_Storage_Size, Arg); end if; if Nkind (P) /= N_Task_Definition then @@ -7866,7 +8766,7 @@ package body Sem_Prag is S := Strval (A); declare - Slen : Natural := Natural (String_Length (S)); + Slen : constant Natural := Natural (String_Length (S)); Options : String (1 .. Slen); J : Natural; @@ -7960,6 +8860,18 @@ package body Sem_Prag is Check_Optional_Identifier (Arg1, Name_Entity); Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1))); + ---------------------------------- + -- Suppress_Exception_Locations -- + ---------------------------------- + + -- pragma Suppress_Exception_Locations; + + when Pragma_Suppress_Exception_Locations => + GNAT_Pragma; + Check_Arg_Count (0); + Check_Valid_Configuration_Pragma; + Exception_Locations_Suppressed := True; + ----------------------------- -- Suppress_Initialization -- ----------------------------- @@ -8041,9 +8953,16 @@ package body Sem_Prag is Error_Msg_Sloc := Task_Dispatching_Policy_Sloc; Error_Pragma ("task dispatching policy incompatible with policy#"); + + -- Set new policy, but always preserve System_Location since + -- we like the error message with the run time name. + else Task_Dispatching_Policy := DP; - Task_Dispatching_Policy_Sloc := Loc; + + if Task_Dispatching_Policy_Sloc /= System_Location then + Task_Dispatching_Policy_Sloc := Loc; + end if; end if; end; @@ -8120,7 +9039,7 @@ package body Sem_Prag is when Pragma_Task_Storage => Task_Storage : declare Args : Args_List (1 .. 2); - Names : Name_List (1 .. 2) := ( + Names : constant Name_List (1 .. 2) := ( Name_Task_Type, Name_Top_Guard); @@ -8132,6 +9051,12 @@ package body Sem_Prag is begin GNAT_Pragma; Gather_Associations (Names, Args); + + if No (Task_Type) then + Error_Pragma + ("missing task_type argument for pragma%"); + end if; + Check_Arg_Is_Local_Name (Task_Type); Ent := Entity (Task_Type); @@ -8217,7 +9142,7 @@ package body Sem_Prag is when Pragma_Title => Title : declare Args : Args_List (1 .. 2); - Names : Name_List (1 .. 2) := ( + Names : constant Name_List (1 .. 2) := ( Name_Title, Name_Subtitle); @@ -8239,8 +9164,8 @@ package body Sem_Prag is -- pragma Unchecked_Union (first_subtype_LOCAL_NAME) when Pragma_Unchecked_Union => Unchecked_Union : declare - Assoc : Node_Id := Arg1; - Type_Id : Node_Id := Expression (Assoc); + Assoc : constant Node_Id := Arg1; + Type_Id : constant Node_Id := Expression (Assoc); Typ : Entity_Id; Discr : Entity_Id; Tdef : Node_Id; @@ -8287,6 +9212,7 @@ package body Sem_Prag is elsif Is_Limited_Type (Typ) then Error_Msg_N ("Unchecked_Union must not be limited record type", Typ); + Explain_Limited_Type (Typ, Typ); return; else @@ -8379,13 +9305,11 @@ package body Sem_Prag is end loop; end if; - Set_Is_Unchecked_Union (Typ, True); - Set_Suppress_Discriminant_Checks (Typ, True); - Set_Convention (Typ, Convention_C); + Set_Is_Unchecked_Union (Typ, True); + Set_Convention (Typ, Convention_C); Set_Has_Unchecked_Union (Base_Type (Typ), True); Set_Is_Unchecked_Union (Base_Type (Typ), True); - end Unchecked_Union; ------------------------ @@ -8399,8 +9323,10 @@ package body Sem_Prag is -- appears in the body, not in the spec). when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare - Cunitent : Entity_Id := Cunit_Entity (Get_Source_Unit (Loc)); - Ent_Kind : Entity_Kind := Ekind (Cunitent); + Cunitent : constant Entity_Id := + Cunit_Entity (Get_Source_Unit (Loc)); + Ent_Kind : constant Entity_Kind := + Ekind (Cunitent); begin GNAT_Pragma; @@ -8424,12 +9350,22 @@ package body Sem_Prag is -- Universal_Data -- -------------------- - -- pragma Universal_Data; + -- pragma Universal_Data [(library_unit_NAME)]; when Pragma_Universal_Data => GNAT_Pragma; - Check_Arg_Count (0); - Check_Valid_Library_Unit_Pragma; + + -- If this is a configuration pragma, then set the universal + -- addressing option, otherwise confirm that the pragma + -- satisfies the requirements of library unit pragma placement + -- and leave it to the GNAAMP back end to detect the pragma + -- (avoids transitive setting of the option due to withed units). + + if Is_Configuration_Pragma then + Universal_Addressing_On_AAMP := True; + else + Check_Valid_Library_Unit_Pragma; + end if; if not AAMP_On_Target then Error_Pragma ("?pragma% ignored (applies only to AAMP)"); @@ -8444,6 +9380,7 @@ package body Sem_Prag is when Pragma_Unreferenced => Unreferenced : declare Arg_Node : Node_Id; Arg_Expr : Node_Id; + Arg_Ent : Entity_Id; begin GNAT_Pragma; @@ -8466,7 +9403,18 @@ package body Sem_Prag is Arg_Expr := Get_Pragma_Arg (Arg_Node); if Is_Entity_Name (Arg_Expr) then - Set_Has_Pragma_Unreferenced (Entity (Arg_Expr)); + Arg_Ent := Entity (Arg_Expr); + + -- If the entity is overloaded, the pragma applies to the + -- most recent overloading, as documented. In this case, + -- name resolution does not generate a reference, so it + -- must be done here explicitly. + + if Is_Overloaded (Arg_Expr) then + Generate_Reference (Arg_Ent, N); + end if; + + Set_Has_Pragma_Unreferenced (Arg_Ent); end if; Next (Arg_Node); @@ -8529,7 +9477,7 @@ package body Sem_Prag is S := Strval (A); declare - Slen : Natural := Natural (String_Length (S)); + Slen : constant Natural := Natural (String_Length (S)); Options : String (1 .. Slen); J : Natural; @@ -8587,7 +9535,7 @@ package body Sem_Prag is -- pragma Warnings (On | Off, [LOCAL_NAME]) - when Pragma_Warnings => + when Pragma_Warnings => Warnings : begin GNAT_Pragma; Check_At_Least_N_Arguments (1); Check_At_Most_N_Arguments (2); @@ -8640,6 +9588,7 @@ package body Sem_Prag is end if; end; end if; + end Warnings; ------------------- -- Weak_External -- @@ -8675,13 +9624,31 @@ package body Sem_Prag is end if; end Weak_External; + -------------------- + -- Unknown_Pragma -- + -------------------- + + -- Should be impossible, since the case of an unknown pragma is + -- separately processed before the case statement is entered. + + when Unknown_Pragma => + raise Program_Error; + end case; exception when Pragma_Exit => null; - end Analyze_Pragma; + --------------------------------- + -- Delay_Config_Pragma_Analyze -- + --------------------------------- + + function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is + begin + return Chars (N) = Name_Interrupt_State; + end Delay_Config_Pragma_Analyze; + ------------------------- -- Get_Base_Subprogram -- ------------------------- @@ -8707,15 +9674,193 @@ package body Sem_Prag is return Result; end Get_Base_Subprogram; - --------------------------- - -- Is_Generic_Subprogram -- - --------------------------- + ----------------------------------------- + -- Is_Non_Significant_Pragma_Reference -- + ----------------------------------------- + + -- This function makes use of the following static table which indicates + -- whether a given pragma is significant. A value of -1 in this table + -- indicates that the reference is significant. A value of zero indicates + -- than appearence as any argument is insignificant, a positive value + -- indicates that appearence in that parameter position is significant. + + Sig_Flags : array (Pragma_Id) of Int := + (Pragma_AST_Entry => -1, + Pragma_Abort_Defer => -1, + Pragma_Ada_83 => -1, + Pragma_Ada_95 => -1, + Pragma_All_Calls_Remote => -1, + Pragma_Annotate => -1, + Pragma_Assert => -1, + Pragma_Asynchronous => -1, + Pragma_Atomic => 0, + Pragma_Atomic_Components => 0, + Pragma_Attach_Handler => -1, + Pragma_CPP_Class => 0, + Pragma_CPP_Constructor => 0, + Pragma_CPP_Virtual => 0, + Pragma_CPP_Vtable => 0, + Pragma_C_Pass_By_Copy => 0, + Pragma_Comment => 0, + Pragma_Common_Object => -1, + Pragma_Compile_Time_Warning => -1, + Pragma_Complex_Representation => 0, + Pragma_Component_Alignment => -1, + Pragma_Controlled => 0, + Pragma_Convention => 0, + Pragma_Convention_Identifier => 0, + Pragma_Debug => -1, + Pragma_Discard_Names => 0, + Pragma_Elaborate => -1, + Pragma_Elaborate_All => -1, + Pragma_Elaborate_Body => -1, + Pragma_Elaboration_Checks => -1, + Pragma_Eliminate => -1, + Pragma_Explicit_Overriding => -1, + Pragma_Export => -1, + Pragma_Export_Exception => -1, + Pragma_Export_Function => -1, + Pragma_Export_Object => -1, + Pragma_Export_Procedure => -1, + Pragma_Export_Value => -1, + Pragma_Export_Valued_Procedure => -1, + Pragma_Extend_System => -1, + Pragma_Extensions_Allowed => -1, + Pragma_External => -1, + Pragma_External_Name_Casing => -1, + Pragma_Finalize_Storage_Only => 0, + Pragma_Float_Representation => 0, + Pragma_Ident => -1, + Pragma_Import => +2, + Pragma_Import_Exception => 0, + Pragma_Import_Function => 0, + Pragma_Import_Object => 0, + Pragma_Import_Procedure => 0, + Pragma_Import_Valued_Procedure => 0, + Pragma_Initialize_Scalars => -1, + Pragma_Inline => 0, + Pragma_Inline_Always => 0, + Pragma_Inline_Generic => 0, + Pragma_Inspection_Point => -1, + Pragma_Interface => +2, + Pragma_Interface_Name => +2, + Pragma_Interrupt_Handler => -1, + Pragma_Interrupt_Priority => -1, + Pragma_Interrupt_State => -1, + Pragma_Java_Constructor => -1, + Pragma_Java_Interface => -1, + Pragma_Keep_Names => 0, + Pragma_License => -1, + Pragma_Link_With => -1, + Pragma_Linker_Alias => -1, + Pragma_Linker_Options => -1, + Pragma_Linker_Section => -1, + Pragma_List => -1, + Pragma_Locking_Policy => -1, + Pragma_Long_Float => -1, + Pragma_Machine_Attribute => -1, + Pragma_Main => -1, + Pragma_Main_Storage => -1, + Pragma_Memory_Size => -1, + Pragma_No_Return => 0, + Pragma_No_Run_Time => -1, + Pragma_Normalize_Scalars => -1, + Pragma_Obsolescent => 0, + Pragma_Optimize => -1, + Pragma_Optional_Overriding => -1, + Pragma_Overriding => -1, + Pragma_Pack => 0, + Pragma_Page => -1, + Pragma_Passive => -1, + Pragma_Polling => -1, + Pragma_Persistent_Data => -1, + Pragma_Persistent_Object => -1, + Pragma_Preelaborate => -1, + Pragma_Priority => -1, + Pragma_Propagate_Exceptions => -1, + Pragma_Psect_Object => -1, + Pragma_Pure => 0, + Pragma_Pure_Function => 0, + Pragma_Queuing_Policy => -1, + Pragma_Ravenscar => -1, + Pragma_Remote_Call_Interface => -1, + Pragma_Remote_Types => -1, + Pragma_Restricted_Run_Time => -1, + Pragma_Restriction_Warnings => -1, + Pragma_Restrictions => -1, + Pragma_Reviewable => -1, + Pragma_Share_Generic => -1, + Pragma_Shared => -1, + Pragma_Shared_Passive => -1, + Pragma_Source_File_Name => -1, + Pragma_Source_File_Name_Project => -1, + Pragma_Source_Reference => -1, + Pragma_Storage_Size => -1, + Pragma_Storage_Unit => -1, + Pragma_Stream_Convert => -1, + Pragma_Style_Checks => -1, + Pragma_Subtitle => -1, + Pragma_Suppress => 0, + Pragma_Suppress_Exception_Locations => 0, + Pragma_Suppress_All => -1, + Pragma_Suppress_Debug_Info => 0, + Pragma_Suppress_Initialization => 0, + Pragma_System_Name => -1, + Pragma_Task_Dispatching_Policy => -1, + Pragma_Task_Info => -1, + Pragma_Task_Name => -1, + Pragma_Task_Storage => 0, + Pragma_Time_Slice => -1, + Pragma_Title => -1, + Pragma_Unchecked_Union => -1, + Pragma_Unimplemented_Unit => -1, + Pragma_Universal_Data => -1, + Pragma_Unreferenced => -1, + Pragma_Unreserve_All_Interrupts => -1, + Pragma_Unsuppress => 0, + Pragma_Use_VADS_Size => -1, + Pragma_Validity_Checks => -1, + Pragma_Volatile => 0, + Pragma_Volatile_Components => 0, + Pragma_Warnings => -1, + Pragma_Weak_External => 0, + Unknown_Pragma => 0); + + function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is + P : Node_Id; + C : Int; + A : Node_Id; - function Is_Generic_Subprogram (Id : Entity_Id) return Boolean is begin - return Ekind (Id) = E_Generic_Procedure - or else Ekind (Id) = E_Generic_Function; - end Is_Generic_Subprogram; + P := Parent (N); + + if Nkind (P) /= N_Pragma_Argument_Association then + return False; + + else + C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P)))); + + case C is + when -1 => + return False; + + when 0 => + return True; + + when others => + A := First (Pragma_Argument_Associations (Parent (P))); + for J in 1 .. C - 1 loop + if No (A) then + return False; + end if; + + Next (A); + end loop; + + return A = P; + end case; + end if; + end Is_Non_Significant_Pragma_Reference; ------------------------------ -- Is_Pragma_String_Literal -- |