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_res.adb | |
| parent | 1c662558a1113238a624245a45382d3df90ccf13 (diff) | |
| download | ppe42-gcc-9dfe12ae5b94d03c997ea2903022a5d2d5c5f266.tar.gz ppe42-gcc-9dfe12ae5b94d03c997ea2903022a5d2d5c5f266.zip | |
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_res.adb')
| -rw-r--r-- | gcc/ada/sem_res.adb | 1013 |
1 files changed, 731 insertions, 282 deletions
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 6df80d22570..68c45f65409 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.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- -- @@ -32,6 +32,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; with Exp_Ch7; use Exp_Ch7; +with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Itypes; use Itypes; @@ -60,6 +61,7 @@ with Sem_Util; use Sem_Util; with Sem_Type; use Sem_Type; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; +with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Targparm; use Targparm; @@ -105,8 +107,8 @@ package body Sem_Res is procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); -- If the type of the object being initialized uses the secondary stack -- directly or indirectly, create a transient scope for the call to the - -- Init_Proc. This is because we do not create transient scopes for the - -- initialization of individual components within the init_proc itself. + -- init proc. This is because we do not create transient scopes for the + -- initialization of individual components within the init proc itself. -- Could be optimized away perhaps? function Is_Predefined_Op (Nam : Entity_Id) return Boolean; @@ -174,6 +176,9 @@ package body Sem_Res is -- A call to a user-defined intrinsic operator is rewritten as a call -- to the corresponding predefined operator, with suitable conversions. + procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); + -- Ditto, for unary operators (only arithmetic ones). + procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); -- If an operator node resolves to a call to a user-defined operator, -- rewrite the node as a function call. @@ -197,7 +202,7 @@ package body Sem_Res is -- not a N_String_Literal node, then the call has no effect. procedure Set_Slice_Subtype (N : Node_Id); - -- Build subtype of array type, with the range specified by the slice. + -- Build subtype of array type, with the range specified by the slice function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; -- A universal_fixed expression in an universal context is unambiguous @@ -247,7 +252,7 @@ package body Sem_Res is procedure Analyze_And_Resolve (N : Node_Id) is begin Analyze (N); - Resolve (N, Etype (N)); + Resolve (N); end Analyze_And_Resolve; procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is @@ -263,12 +268,12 @@ package body Sem_Res is Typ : Entity_Id; Suppress : Check_Id) is - Scop : Entity_Id := Current_Scope; + Scop : constant Entity_Id := Current_Scope; begin if Suppress = All_Checks then declare - Svg : constant Suppress_Record := Scope_Suppress; + Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); @@ -278,12 +283,12 @@ package body Sem_Res is else declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress (Suppress); begin - Set_Scope_Suppress (Suppress, True); + Scope_Suppress (Suppress) := True; Analyze_And_Resolve (N, Typ); - Set_Scope_Suppress (Suppress, Svg); + Scope_Suppress (Suppress) := Svg; end; end if; @@ -305,12 +310,12 @@ package body Sem_Res is (N : Node_Id; Suppress : Check_Id) is - Scop : Entity_Id := Current_Scope; + Scop : constant Entity_Id := Current_Scope; begin if Suppress = All_Checks then declare - Svg : constant Suppress_Record := Scope_Suppress; + Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); @@ -320,12 +325,12 @@ package body Sem_Res is else declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress (Suppress); begin - Set_Scope_Suppress (Suppress, True); + Scope_Suppress (Suppress) := True; Analyze_And_Resolve (N); - Set_Scope_Suppress (Suppress, Svg); + Scope_Suppress (Suppress) := Svg; end; end if; @@ -416,6 +421,10 @@ package body Sem_Res is -- any array whose index type covered the whole range of -- the type would likely raise Storage_Error. + ------------------------ + -- Large_Storage_Type -- + ------------------------ + function Large_Storage_Type (T : Entity_Id) return Boolean is begin return @@ -490,8 +499,8 @@ package body Sem_Res is -- Warn about the danger Error_Msg_N - ("creation of object of this type may raise Storage_Error?", - N); + ("creation of & object may raise Storage_Error?", + Scope (Disc)); <<No_Danger>> null; @@ -535,15 +544,16 @@ package body Sem_Res is if (Nkind (P) = N_Subtype_Indication and then (Nkind (Parent (P)) = N_Component_Declaration - or else Nkind (Parent (P)) = N_Derived_Type_Definition) + or else + Nkind (Parent (P)) = N_Derived_Type_Definition) and then D = Constraint (P)) -- The constraint itself may be given by a subtype indication, -- rather than by a more common discrete range. or else (Nkind (P) = N_Subtype_Indication - and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) - + and then + Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) or else Nkind (P) = N_Entry_Declaration or else Nkind (D) = N_Defining_Identifier then @@ -558,21 +568,8 @@ package body Sem_Res is -------------------------------- procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is - Orig_Node : Node_Id := Original_Node (N); - begin - if Comes_From_Source (Orig_Node) - and then not In_Open_Scopes (Scope (T)) - and then not Is_Potentially_Use_Visible (T) - and then not In_Use (T) - and then not In_Use (Scope (T)) - and then (not Present (Entity (N)) - or else Ekind (Entity (N)) /= E_Function) - and then (Nkind (Orig_Node) /= N_Function_Call - or else Nkind (Name (Orig_Node)) /= N_Expanded_Name - or else Entity (Prefix (Name (Orig_Node))) /= Scope (T)) - and then not In_Instance - then + if Is_Invisible_Operator (N, T) then Error_Msg_NE ("operator for} is not directly visible!", N, First_Subtype (T)); Error_Msg_N ("use clause would make operation legal!", N); @@ -678,10 +675,8 @@ package body Sem_Res is end if; end loop; - Warn_On_Instance := True; Error_Msg_N ("possible infinite recursion?", N); Error_Msg_N ("\Storage_Error may be raised at run time?", N); - Warn_On_Instance := False; return True; end Check_Infinite_Recursion; @@ -691,7 +686,7 @@ package body Sem_Res is ------------------------------- procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is - Typ : Entity_Id := Etype (First_Formal (Nam)); + Typ : constant Entity_Id := Etype (First_Formal (Nam)); function Uses_SS (T : Entity_Id) return Boolean; -- Check whether the creation of an object of the type will involve @@ -725,7 +720,11 @@ package body Sem_Res is then Expr := Expression (Parent (Comp)); - if Nkind (Expr) = N_Function_Call + -- The expression for a dynamic component may be + -- rewritten as a dereference. Retrieve original + -- call. + + if Nkind (Original_Node (Expr)) = N_Function_Call and then Requires_Transient_Scope (Etype (Expr)) then return True; @@ -779,6 +778,8 @@ package body Sem_Res is then return; end if; + + Require_Entity (N); end if; -- Rewrite as call if overloadable entity that is (or could be, in @@ -806,10 +807,11 @@ package body Sem_Res is or else (Nkind (N) = N_Selected_Component and then (Ekind (Entity (Selector_Name (N))) = E_Function - or else ((Ekind (Entity (Selector_Name (N))) = E_Entry - or else - Ekind (Entity (Selector_Name (N))) = E_Procedure) - and then Is_Overloaded (Selector_Name (N))))) + or else + ((Ekind (Entity (Selector_Name (N))) = E_Entry + or else + Ekind (Entity (Selector_Name (N))) = E_Procedure) + and then Is_Overloaded (Selector_Name (N))))) -- If one of the above three conditions is met, rewrite as call. -- Apply the rewriting only once. @@ -999,10 +1001,6 @@ package body Sem_Res is end if; end Type_In_P; - --------------------------- - -- Operand_Type_In_Scope -- - --------------------------- - -- Start of processing for Make_Call_Into_Operator begin @@ -1157,11 +1155,37 @@ package body Sem_Res is end if; Set_Chars (Op_Node, Op_Name); - Set_Etype (Op_Node, Base_Type (Etype (N))); + + if not Is_Private_Type (Etype (N)) then + Set_Etype (Op_Node, Base_Type (Etype (N))); + else + Set_Etype (Op_Node, Etype (N)); + end if; + Set_Entity (Op_Node, Op_Id); Generate_Reference (Op_Id, N, ' '); Rewrite (N, Op_Node); - Resolve (N, Typ); + + -- If this is an arithmetic operator and the result type is private, + -- the operands and the result must be wrapped in conversion to + -- expose the underlying numeric type and expand the proper checks, + -- e.g. on division. + + if Is_Private_Type (Typ) then + case Nkind (N) is + when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide | + N_Op_Expon | N_Op_Mod | N_Op_Rem => + Resolve_Intrinsic_Operator (N, Typ); + + when N_Op_Plus | N_Op_Minus | N_Op_Abs => + Resolve_Intrinsic_Unary_Operator (N, Typ); + + when others => + Resolve (N, Typ); + end case; + else + Resolve (N, Typ); + end if; -- For predefined operators on literals, the operation freezes -- their type. @@ -1331,6 +1355,7 @@ package body Sem_Res is Seen : Entity_Id := Empty; -- prevent junk warning Ctx_Type : Entity_Id := Typ; Expr_Type : Entity_Id := Empty; -- prevent junk warning + Err_Type : Entity_Id := Empty; Ambiguous : Boolean := False; procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); @@ -1493,9 +1518,14 @@ package body Sem_Res is end if; end if; - if Attr = Attribute_Access - or else Attr = Attribute_Unchecked_Access - or else Attr = Attribute_Unrestricted_Access + -- If we are generating code for a distributed program. + -- perform semantic checks against the corresponding + -- remote entities. + + if (Attr = Attribute_Access + or else Attr = Attribute_Unchecked_Access + or else Attr = Attribute_Unrestricted_Access) + and then Expander_Active then Check_Subtype_Conformant (New_Id => Entity (Prefix (N)), @@ -1559,8 +1589,13 @@ package body Sem_Res is -- We are only interested in interpretations that are compatible -- with the expected type, any other interpretations are ignored - if Covers (Typ, It.Typ) then + if not Covers (Typ, It.Typ) then + if Debug_Flag_V then + Write_Str (" interpretation incompatible with context"); + Write_Eol; + end if; + else -- First matching interpretation if not Found then @@ -1569,7 +1604,7 @@ package body Sem_Res is Seen := It.Nam; Expr_Type := It.Typ; - -- Matching intepretation that is not the first, maybe an + -- Matching interpretation that is not the first, maybe an -- error, but there are some cases where preference rules are -- used to choose between the two possibilities. These and -- some more obscure cases are handled in Disambiguate. @@ -1578,8 +1613,18 @@ package body Sem_Res is Error_Msg_Sloc := Sloc (Seen); It1 := Disambiguate (N, I1, I, Typ); - if It1 = No_Interp then + -- Disambiguation has succeeded. Skip the remaining + -- interpretations. + if It1 /= No_Interp then + Seen := It1.Nam; + Expr_Type := It1.Typ; + + while Present (It.Typ) loop + Get_Next_Interp (I, It); + end loop; + + else -- Before we issue an ambiguity complaint, check for -- the case of a subprogram call where at least one -- of the arguments is Any_Type, and if so, suppress @@ -1633,23 +1678,61 @@ package body Sem_Res is Error_Msg_NE ("ambiguous expression (cannot resolve&)!", N, It.Nam); + Error_Msg_N ("possible interpretation#!", N); Ambiguous := True; end if; Error_Msg_Sloc := Sloc (It.Nam); - Error_Msg_N ("possible interpretation#!", N); - -- Disambiguation has succeeded. Skip the remaining - -- interpretations. - else - Seen := It1.Nam; - Expr_Type := It1.Typ; + -- By default, the error message refers to the candidate + -- interpretation. But if it is a predefined operator, + -- it is implicitly declared at the declaration of + -- the type of the operand. Recover the sloc of that + -- declaration for the error message. + + if Nkind (N) in N_Op + and then Scope (It.Nam) = Standard_Standard + and then not Is_Overloaded (Right_Opnd (N)) + and then Scope (Base_Type (Etype (Right_Opnd (N)))) + /= Standard_Standard + then + Err_Type := First_Subtype (Etype (Right_Opnd (N))); + + if Comes_From_Source (Err_Type) + and then Present (Parent (Err_Type)) + then + Error_Msg_Sloc := Sloc (Parent (Err_Type)); + end if; + + elsif Nkind (N) in N_Binary_Op + and then Scope (It.Nam) = Standard_Standard + and then not Is_Overloaded (Left_Opnd (N)) + and then Scope (Base_Type (Etype (Left_Opnd (N)))) + /= Standard_Standard + then + Err_Type := First_Subtype (Etype (Left_Opnd (N))); + + if Comes_From_Source (Err_Type) + and then Present (Parent (Err_Type)) + then + Error_Msg_Sloc := Sloc (Parent (Err_Type)); + end if; + else + Err_Type := Empty; + end if; + + if Nkind (N) in N_Op + and then Scope (It.Nam) = Standard_Standard + and then Present (Err_Type) + then + Error_Msg_N + ("possible interpretation (predefined)#!", N); + else + Error_Msg_N ("possible interpretation#!", N); + end if; - while Present (It.Typ) loop - Get_Next_Interp (I, It); - end loop; end if; end if; @@ -1708,13 +1791,6 @@ package body Sem_Res is Set_Etype (Name (N), Expr_Type); end if; - -- Here if interpetation is incompatible with context type - - else - if Debug_Flag_V then - Write_Str (" intepretation incompatible with context"); - Write_Eol; - end if; end if; -- Move to next interpretation @@ -1785,7 +1861,6 @@ package body Sem_Res is elsif Nkind (N) = N_Aggregate and then Etype (N) = Any_Composite then - -- Disable expansion in any case. If there is a type mismatch -- it may be fatal to try to expand the aggregate. The flag -- would otherwise be set to false when the error is posted. @@ -1822,6 +1897,10 @@ package body Sem_Res is end if; end Check_Aggr; + ---------------- + -- Check_Elmt -- + ---------------- + procedure Check_Elmt (Aelmt : Node_Id) is begin -- If we have a nested aggregate, go inside it (to @@ -1839,7 +1918,7 @@ package body Sem_Res is if not Is_Overloaded (Aelmt) and then Etype (Aelmt) /= Any_Fixed then - Resolve (Aelmt, Etype (Aelmt)); + Resolve (Aelmt); end if; if Etype (Aelmt) = Any_Type then @@ -2081,7 +2160,7 @@ package body Sem_Res is Set_Is_Overloaded (N, False); -- Freeze expression type, entity if it is a name, and designated - -- type if it is an allocator (RM 13.14(9,10)). + -- type if it is an allocator (RM 13.14(10,11,13)). -- Now that the resolution of the type of the node is complete, -- and we did not detect an error, we can expand this node. We @@ -2100,16 +2179,19 @@ package body Sem_Res is Expand (N); end if; - end Resolve; + ------------- + -- Resolve -- + ------------- + -- Version with check(s) suppressed procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is begin if Suppress = All_Checks then declare - Svg : constant Suppress_Record := Scope_Suppress; + Svg : constant Suppress_Array := Scope_Suppress; begin Scope_Suppress := (others => True); @@ -2119,16 +2201,27 @@ package body Sem_Res is else declare - Svg : constant Boolean := Get_Scope_Suppress (Suppress); + Svg : constant Boolean := Scope_Suppress (Suppress); begin - Set_Scope_Suppress (Suppress, True); + Scope_Suppress (Suppress) := True; Resolve (N, Typ); - Set_Scope_Suppress (Suppress, Svg); + Scope_Suppress (Suppress) := Svg; end; end if; end Resolve; + ------------- + -- Resolve -- + ------------- + + -- Version with implicit type + + procedure Resolve (N : Node_Id) is + begin + Resolve (N, Etype (N)); + end Resolve; + --------------------- -- Resolve_Actuals -- --------------------- @@ -2146,6 +2239,11 @@ package body Sem_Res is -- an instance of the default expression. The insertion is always -- a named association. + function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; + -- Check whether T1 and T2, or their full views, are derived from a + -- common type. Used to enforce the restrictions on array conversions + -- of AI95-00246. + -------------------- -- Insert_Default -- -------------------- @@ -2155,13 +2253,17 @@ package body Sem_Res is Assoc : Node_Id; begin - -- Note that we do a full New_Copy_Tree, so that any associated - -- Itypes are properly copied. This may not be needed any more, - -- but it does no harm as a safety measure! Defaults of a generic - -- formal may be out of bounds of the corresponding actual (see - -- cc1311b) and an additional check may be required. + -- Missing argument in call, nothing to insert - if Present (Default_Value (F)) then + if No (Default_Value (F)) then + return; + + else + -- Note that we do a full New_Copy_Tree, so that any associated + -- Itypes are properly copied. This may not be needed any more, + -- but it does no harm as a safety measure! Defaults of a generic + -- formal may be out of bounds of the corresponding actual (see + -- cc1311b) and an additional check may be required. Actval := New_Copy_Tree (Default_Value (F), New_Scope => Current_Scope, New_Sloc => Loc); @@ -2194,9 +2296,6 @@ package body Sem_Res is end if; Set_Parent (Actval, N); - Analyze_And_Resolve (Actval, Etype (Actval)); - else - Set_Parent (Actval, N); -- Resolve aggregates with their base type, to avoid scope -- anomalies: the subtype was first built in the suprogram @@ -2209,6 +2308,28 @@ package body Sem_Res is else Analyze_And_Resolve (Actval, Etype (Actval)); end if; + + else + Set_Parent (Actval, N); + + -- See note above concerning aggregates. + + if Nkind (Actval) = N_Aggregate + and then Has_Discriminants (Etype (Actval)) + then + Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); + + -- Resolve entities with their own type, which may differ + -- from the type of a reference in a generic context (the + -- view swapping mechanism did not anticipate the re-analysis + -- of default values in calls). + + elsif Is_Entity_Name (Actval) then + Analyze_And_Resolve (Actval, Etype (Entity (Actval))); + + else + Analyze_And_Resolve (Actval, Etype (Actval)); + end if; end if; -- If default is a tag indeterminate function call, propagate @@ -2220,9 +2341,6 @@ package body Sem_Res is Set_Is_Controlling_Actual (Actval); end if; - else - -- Missing argument in call, nothing to insert. - return; end if; -- If the default expression raises constraint error, then just @@ -2276,6 +2394,30 @@ package body Sem_Res is Prev := Actval; end Insert_Default; + ------------------- + -- Same_Ancestor -- + ------------------- + + function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is + FT1 : Entity_Id := T1; + FT2 : Entity_Id := T2; + + begin + if Is_Private_Type (T1) + and then Present (Full_View (T1)) + then + FT1 := Full_View (T1); + end if; + + if Is_Private_Type (T2) + and then Present (Full_View (T2)) + then + FT2 := Full_View (T2); + end if; + + return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); + end Same_Ancestor; + -- Start of processing for Resolve_Actuals begin @@ -2283,13 +2425,15 @@ package body Sem_Res is F := First_Formal (Nam); while Present (F) loop + if No (A) and then Needs_No_Actuals (Nam) then + null; -- If we have an error in any actual or formal, indicated by -- a type of Any_Type, then abandon resolution attempt, and -- set result type to Any_Type. - if (No (A) or else Etype (A) = Any_Type or else Etype (F) = Any_Type) - and then Total_Errors_Detected /= 0 + elsif (Present (A) and then Etype (A) = Any_Type) + or else Etype (F) = Any_Type then Set_Etype (N, Any_Type); return; @@ -2316,54 +2460,91 @@ package body Sem_Res is then if Ekind (F) = E_In_Out_Parameter and then Is_Array_Type (Etype (F)) - and then Has_Aliased_Components (Etype (Expression (A))) - /= Has_Aliased_Components (Etype (F)) then - Error_Msg_N - ("both component types in a view conversion must be" - & " aliased, or neither", A); + if Has_Aliased_Components (Etype (Expression (A))) + /= Has_Aliased_Components (Etype (F)) + then + Error_Msg_N + ("both component types in a view conversion must be" + & " aliased, or neither", A); + + elsif not Same_Ancestor (Etype (F), Etype (Expression (A))) + and then + (Is_By_Reference_Type (Etype (F)) + or else Is_By_Reference_Type (Etype (Expression (A)))) + then + Error_Msg_N + ("view conversion between unrelated by_reference " + & "array types not allowed (\A\I-00246)?", A); + end if; end if; if Conversion_OK (A) or else Valid_Conversion (A, Etype (A), Expression (A)) then - Resolve (Expression (A), Etype (Expression (A))); + Resolve (Expression (A)); end if; else + if Nkind (A) = N_Type_Conversion + and then Is_Array_Type (Etype (F)) + and then not Same_Ancestor (Etype (F), Etype (Expression (A))) + and then + (Is_Limited_Type (Etype (F)) + or else Is_Limited_Type (Etype (Expression (A)))) + then + Error_Msg_N + ("Conversion between unrelated limited array types " + & "not allowed (\A\I-00246)?", A); + + -- Disable explanation (which produces additional errors) + -- until AI is approved and warning becomes an error. + + -- if Is_Limited_Type (Etype (F)) then + -- Explain_Limited_Type (Etype (F), A); + -- end if; + + -- if Is_Limited_Type (Etype (Expression (A))) then + -- Explain_Limited_Type (Etype (Expression (A)), A); + -- end if; + end if; + Resolve (A, Etype (F)); end if; A_Typ := Etype (A); F_Typ := Etype (F); - if Ekind (F) /= E_In_Parameter - and then not Is_OK_Variable_For_Out_Formal (A) - then - -- Specialize error message for protected procedure call - -- within function call of the same protected object. - - if Is_Entity_Name (A) - and then Chars (Entity (A)) = Name_uObject - and then Ekind (Current_Scope) = E_Function - and then Convention (Current_Scope) = Convention_Protected - and then Ekind (Nam) /= E_Function + -- Perform error checks for IN and IN OUT parameters + + if Ekind (F) /= E_Out_Parameter then + + -- Check unset reference. For scalar parameters, it is clearly + -- wrong to pass an uninitialized value as either an IN or + -- IN-OUT parameter. For composites, it is also clearly an + -- error to pass a completely uninitialized value as an IN + -- parameter, but the case of IN OUT is trickier. We prefer + -- not to give a warning here. For example, suppose there is + -- a routine that sets some component of a record to False. + -- It is perfectly reasonable to make this IN-OUT and allow + -- either initialized or uninitialized records to be passed + -- in this case. + + -- For partially initialized composite values, we also avoid + -- warnings, since it is quite likely that we are passing a + -- partially initialized value and only the initialized fields + -- will in fact be read in the subprogram. + + if Is_Scalar_Type (A_Typ) + or else (Ekind (F) = E_In_Parameter + and then not Is_Partially_Initialized_Type (A_Typ)) then - Error_Msg_N ("within protected function, protected " & - "object is constant", A); - Error_Msg_N ("\cannot call operation that may modify it", A); - else - Error_Msg_NE ("actual for& must be a variable", A, F); + Check_Unset_Reference (A); end if; - end if; - if Etype (A) = Any_Type then - Set_Etype (N, Any_Type); - return; - end if; - - if Ekind (F) /= E_Out_Parameter then - Check_Unset_Reference (A); + -- In Ada 83 we cannot pass an OUT parameter as an IN + -- or IN OUT actual to a nested call, since this is a + -- case of reading an out parameter, which is not allowed. if Ada_83 and then Is_Entity_Name (A) @@ -2373,6 +2554,23 @@ package body Sem_Res is end if; end if; + if Ekind (F) /= E_In_Parameter + and then not Is_OK_Variable_For_Out_Formal (A) + then + Error_Msg_NE ("actual for& must be a variable", A, F); + + if Is_Entity_Name (A) then + Kill_Checks (Entity (A)); + else + Kill_All_Checks; + end if; + end if; + + if Etype (A) = Any_Type then + Set_Etype (N, Any_Type); + return; + end if; + -- Apply appropriate range checks for in, out, and in-out -- parameters. Out and in-out parameters also need a separate -- check, if there is a type conversion, to make sure the return @@ -2421,7 +2619,6 @@ package body Sem_Res is if Ekind (F) = E_Out_Parameter or else Ekind (F) = E_In_Out_Parameter then - if Nkind (A) = N_Type_Conversion then if Is_Scalar_Type (A_Typ) then Apply_Scalar_Range_Check @@ -2536,15 +2733,21 @@ package body Sem_Res is end if; Prev := A; + + if Ekind (F) /= E_Out_Parameter then + Check_Unset_Reference (A); + end if; + Next_Actual (A); + -- Case where actual is not present + else Insert_Default; end if; Next_Formal (F); end loop; - end Resolve_Actuals; ----------------------- @@ -2605,6 +2808,16 @@ package body Sem_Res is Resolve (Expression (E), Etype (E)); Check_Unset_Reference (Expression (E)); + -- A qualified expression requires an exact match of the type, + -- class-wide matching is not allowed. + + if (Is_Class_Wide_Type (Etype (Expression (E))) + or else Is_Class_Wide_Type (Etype (E))) + and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) + then + Wrong_Type (Expression (E), Etype (E)); + end if; + -- For a subtype mark or subtype indication, freeze the subtype else @@ -2703,11 +2916,12 @@ package body Sem_Res is -- Used for resolving all arithmetic operators except exponentiation procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is - L : constant Node_Id := Left_Opnd (N); - R : constant Node_Id := Right_Opnd (N); - T : Entity_Id; - TL : Entity_Id := Base_Type (Etype (L)); - TR : Entity_Id := Base_Type (Etype (R)); + L : constant Node_Id := Left_Opnd (N); + R : constant Node_Id := Right_Opnd (N); + TL : constant Entity_Id := Base_Type (Etype (L)); + TR : constant Entity_Id := Base_Type (Etype (R)); + T : Entity_Id; + Rop : Node_Id; B_Typ : constant Entity_Id := Base_Type (Typ); -- We do the resolution using the base type, because intermediate values @@ -2724,9 +2938,6 @@ package body Sem_Res is procedure Set_Operand_Type (N : Node_Id); -- Set operand type to T if universal - function Universal_Interpretation (N : Node_Id) return Entity_Id; - -- Find universal type of operand, if any. - ----------------------------- -- Is_Integer_Or_Universal -- ----------------------------- @@ -2836,7 +3047,6 @@ package body Sem_Res is Get_First_Interp (N, Index, It); while Present (It.Typ) loop - if Base_Type (It.Typ) = Base_Type (Standard_Integer) then if Analyzed (N) then @@ -2868,7 +3078,7 @@ package body Sem_Res is end if; else - Resolve (N, Etype (N)); + Resolve (N); end if; end Set_Mixed_Mode_Operand; @@ -2885,50 +3095,13 @@ package body Sem_Res is end if; end Set_Operand_Type; - ------------------------------ - -- Universal_Interpretation -- - ------------------------------ - - function Universal_Interpretation (N : Node_Id) return Entity_Id is - Index : Interp_Index; - It : Interp; - - begin - if not Is_Overloaded (N) then - - if Etype (N) = Universal_Integer - or else Etype (N) = Universal_Real - then - return Etype (N); - else - return Empty; - end if; - - else - Get_First_Interp (N, Index, It); - - while Present (It.Typ) loop - - if It.Typ = Universal_Integer - or else It.Typ = Universal_Real - then - return It.Typ; - end if; - - Get_Next_Interp (Index, It); - end loop; - - return Empty; - end if; - end Universal_Interpretation; - -- Start of processing for Resolve_Arithmetic_Op begin if Comes_From_Source (N) and then Ekind (Entity (N)) = E_Function and then Is_Imported (Entity (N)) - and then Present (First_Rep_Item (Entity (N))) + and then Is_Intrinsic_Subprogram (Entity (N)) then Resolve_Intrinsic_Operator (N, Typ); return; @@ -3072,7 +3245,7 @@ package body Sem_Res is Set_Operand_Type (R); end if; - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, Typ); Eval_Arithmetic_Op (N); -- Set overflow and division checking bit. Much cleverer code needed @@ -3082,21 +3255,39 @@ package body Sem_Res is if Nkind (N) in N_Op then if not Overflow_Checks_Suppressed (Etype (N)) then - Set_Do_Overflow_Check (N); + Enable_Overflow_Check (N); end if; + -- Give warning if explicit division by zero + if (Nkind (N) = N_Op_Divide or else Nkind (N) = N_Op_Rem or else Nkind (N) = N_Op_Mod) and then not Division_Checks_Suppressed (Etype (N)) then - Set_Do_Division_Check (N); + Rop := Right_Opnd (N); + + if Compile_Time_Known_Value (Rop) + and then ((Is_Integer_Type (Etype (Rop)) + and then Expr_Value (Rop) = Uint_0) + or else + (Is_Real_Type (Etype (Rop)) + and then Expr_Value_R (Rop) = Ureal_0)) + then + Apply_Compile_Time_Constraint_Error + (N, "division by zero?", CE_Divide_By_Zero, + Loc => Sloc (Right_Opnd (N))); + + -- Otherwise just set the flag to check at run time + + else + Set_Do_Division_Check (N); + end if; end if; end if; Check_Unset_Reference (L); Check_Unset_Reference (R); - end Resolve_Arithmetic_Op; ------------------ @@ -3111,6 +3302,7 @@ package body Sem_Res is It : Interp; Norm_OK : Boolean; Scop : Entity_Id; + Decl : Node_Id; begin -- The context imposes a unique interpretation with type Typ on @@ -3136,7 +3328,6 @@ package body Sem_Res is Nam := Empty; while Present (It.Typ) loop - if Covers (Typ, Etype (It.Typ)) then Nam := It.Typ; exit; @@ -3156,6 +3347,14 @@ package body Sem_Res is Resolve (Subp, Nam); end if; + -- For an indirect call, we always invalidate checks, since we + -- do not know whether the subprogram is local or global. Yes + -- we could do better here, e.g. by knowing that there are no + -- local subprograms, but it does not seem worth the effort. + -- Similarly, we kill al knowledge of current constant values. + + Kill_Current_Values; + -- If this is a procedure call which is really an entry call, do -- the conversion of the procedure call to an entry call. Protected -- operations use the same circuitry because the name in the call @@ -3168,6 +3367,11 @@ package body Sem_Res is then Resolve_Entry_Call (N, Typ); Check_Elab_Call (N); + + -- Kill checks and constant values, as above for indirect case + -- Who knows what happens when another task is activated? + + Kill_Current_Values; return; -- Normal subprogram call with name established in Resolve @@ -3219,6 +3423,51 @@ package body Sem_Res is end; end if; + -- If the subprogram is not global, then kill all checks. This is + -- a bit conservative, since in many cases we could do better, but + -- it is not worth the effort. Similarly, we kill constant values. + -- However we do not need to do this for internal entities (unless + -- they are inherited user-defined subprograms), since they are not + -- in the business of molesting global values. + + if not Is_Library_Level_Entity (Nam) + and then (Comes_From_Source (Nam) + or else (Present (Alias (Nam)) + and then Comes_From_Source (Alias (Nam)))) + then + Kill_Current_Values; + end if; + + -- Check for call to obsolescent subprogram + + if Warn_On_Obsolescent_Feature then + Decl := Parent (Parent (Nam)); + + if Nkind (Decl) = N_Subprogram_Declaration + and then Is_List_Member (Decl) + and then Nkind (Next (Decl)) = N_Pragma + then + declare + P : constant Node_Id := Next (Decl); + + begin + if Chars (P) = Name_Obsolescent then + Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam); + + if Pragma_Argument_Associations (P) /= No_List then + Name_Buffer (1) := '|'; + Name_Buffer (2) := '?'; + Name_Len := 2; + Add_String_To_Name_Buffer + (Strval (Expression + (First (Pragma_Argument_Associations (P))))); + Error_Msg_N (Name_Buffer (1 .. Name_Len), N); + end if; + end if; + end; + end if; + end if; + -- Check that a procedure call does not occur in the context -- of the entry call statement of a conditional or timed -- entry call. Note that the case of a call to a subprogram @@ -3235,6 +3484,19 @@ package body Sem_Res is Error_Msg_N ("entry call required in select statement", N); end if; + -- Check that this is not a call to a protected procedure or + -- entry from within a protected function. + + if Ekind (Current_Scope) = E_Function + and then Ekind (Scope (Current_Scope)) = E_Protected_Type + and then Ekind (Nam) /= E_Function + and then Scope (Nam) = Scope (Current_Scope) + then + Error_Msg_N ("within protected function, protected " & + "object is constant", N); + Error_Msg_N ("\cannot call operation that may modify it", N); + end if; + -- Freeze the subprogram name if not in default expression. Note -- that we freeze procedure calls as well as function calls. -- Procedure calls are not frozen according to the rules (RM @@ -3253,7 +3515,6 @@ package body Sem_Res is -- subprogram being called. if Is_Predefined_Op (Nam) then - if Etype (N) /= Universal_Fixed then Set_Etype (N, Typ); end if; @@ -3261,6 +3522,9 @@ package body Sem_Res is -- If the subprogram returns an array type, and the context -- requires the component type of that array type, the node is -- really an indexing of the parameterless call. Resolve as such. + -- A pathological case occurs when the type of the component is + -- an access to the array type. In this case the call is truly + -- ambiguous. elsif Needs_No_Actuals (Nam) and then @@ -3274,25 +3538,36 @@ package body Sem_Res is then declare Index_Node : Node_Id; + New_Subp : Node_Id; + Ret_Type : constant Entity_Id := Etype (Nam); begin - - if Component_Type (Etype (Nam)) /= Any_Type then - Index_Node := - Make_Indexed_Component (Loc, - Prefix => - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Nam, Loc)), - Expressions => Parameter_Associations (N)); - - -- Since we are correcting a node classification error made by - -- the parser, we call Replace rather than Rewrite. - - Replace (N, Index_Node); - Set_Etype (Prefix (N), Etype (Nam)); - Set_Etype (N, Typ); - Resolve_Indexed_Component (N, Typ); - Check_Elab_Call (Prefix (N)); + if Is_Access_Type (Ret_Type) + and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) + then + Error_Msg_N + ("cannot disambiguate function call and indexing", N); + else + New_Subp := Relocate_Node (Subp); + Set_Entity (Subp, Nam); + + if Component_Type (Ret_Type) /= Any_Type then + Index_Node := + Make_Indexed_Component (Loc, + Prefix => + Make_Function_Call (Loc, + Name => New_Subp), + Expressions => Parameter_Associations (N)); + + -- Since we are correcting a node classification error made + -- by the parser, we call Replace rather than Rewrite. + + Replace (N, Index_Node); + Set_Etype (Prefix (N), Ret_Type); + Set_Etype (N, Typ); + Resolve_Indexed_Component (N, Typ); + Check_Elab_Call (Prefix (N)); + end if; end if; return; @@ -3391,8 +3666,9 @@ package body Sem_Res is return; end if; - -- Create a transient scope if the resulting type requires it. - -- There are 3 notable exceptions: in init_procs, the transient scope + -- Create a transient scope if the resulting type requires it + + -- There are 3 notable exceptions: in init procs, the transient scope -- overhead is not needed and even incorrect due to the actual expansion -- of adjust calls; the second case is enumeration literal pseudo calls, -- the other case is intrinsic subprograms (Unchecked_Conversion and @@ -3401,7 +3677,7 @@ package body Sem_Res is -- If this is an initialization call for a type whose initialization -- uses the secondary stack, we also need to create a transient scope - -- for it, precisely because we will not do it within the init_proc + -- for it, precisely because we will not do it within the init proc -- itself. if Expander_Active @@ -3414,7 +3690,7 @@ package body Sem_Res is Establish_Transient_Scope (N, Sec_Stack => not Functions_Return_By_DSP_On_Target); - elsif Chars (Nam) = Name_uInit_Proc + elsif Is_Init_Proc (Nam) and then not Within_Init_Proc then Check_Initialization_Call (N, Nam); @@ -3445,7 +3721,7 @@ package body Sem_Res is Copy_Node (Subp, N); Resolve_Entity_Name (N, Typ); - -- Avoid validation, since it is a static function call. + -- Avoid validation, since it is a static function call return; end if; @@ -3471,7 +3747,6 @@ package body Sem_Res is -- If we fall through we definitely have a non-static call Check_Elab_Call (N); - end Resolve_Call; ------------------------------- @@ -3539,7 +3814,6 @@ package body Sem_Res is Error_Msg_NE ("character not defined for }", N, First_Subtype (B_Typ)); - end Resolve_Character_Literal; --------------------------- @@ -3547,7 +3821,9 @@ package body Sem_Res is --------------------------- -- Context requires a boolean type, and plays no role in resolution. - -- Processing identical to that for equality operators. + -- Processing identical to that for equality operators. The result + -- type is the base type, which matters when pathological subtypes of + -- booleans with limited ranges are used. procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is L : constant Node_Id := Left_Opnd (N); @@ -3570,11 +3846,10 @@ package body Sem_Res is end if; end if; - Set_Etype (N, Typ); + Set_Etype (N, Base_Type (Typ)); Generate_Reference (T, N, ' '); if T /= Any_Type then - if T = Any_String or else T = Any_Composite or else T = Any_Character @@ -3600,11 +3875,10 @@ package body Sem_Res is Resolve (R, T); Check_Unset_Reference (L); Check_Unset_Reference (R); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, T); Eval_Relational_Op (N); end if; end if; - end Resolve_Comparison_Op; ------------------------------------ @@ -3697,8 +3971,8 @@ package body Sem_Res is -- away if either bounds of R are a Constraint_Error. declare - L : Node_Id := Low_Bound (R); - H : Node_Id := High_Bound (R); + L : constant Node_Id := Low_Bound (R); + H : constant Node_Id := High_Bound (R); begin if Nkind (L) = N_Raise_Constraint_Error then @@ -3839,10 +4113,10 @@ package body Sem_Res is ----------------------- function Actual_Index_Type (E : Entity_Id) return Entity_Id is - Typ : Entity_Id := Entry_Index_Type (E); - Tsk : Entity_Id := Scope (E); - Lo : Node_Id := Type_Low_Bound (Typ); - Hi : Node_Id := Type_High_Bound (Typ); + Typ : constant Entity_Id := Entry_Index_Type (E); + Tsk : constant Entity_Id := Scope (E); + Lo : constant Node_Id := Type_Low_Bound (Typ); + Hi : constant Node_Id := Type_High_Bound (Typ); New_T : Entity_Id; function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; @@ -3858,7 +4132,7 @@ package body Sem_Res is ----------------------------- function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is - Typ : Entity_Id := Etype (Bound); + Typ : constant Entity_Id := Etype (Bound); Ref : Node_Id; begin @@ -3986,10 +4260,10 @@ package body Sem_Res is -- protected type. declare - Pref : Node_Id := Prefix (Entry_Name); + Pref : constant Node_Id := Prefix (Entry_Name); + Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); I : Interp_Index; It : Interp; - Ent : Entity_Id := Entity (Selector_Name (Entry_Name)); begin Get_First_Interp (Pref, I, It); @@ -4007,13 +4281,11 @@ package body Sem_Res is end if; if Nkind (Entry_Name) = N_Selected_Component then - Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name))); + Resolve (Prefix (Entry_Name)); else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); Nam := Entity (Selector_Name (Prefix (Entry_Name))); - Resolve (Prefix (Prefix (Entry_Name)), - Etype (Prefix (Prefix (Entry_Name)))); - + Resolve (Prefix (Prefix (Entry_Name))); Index := First (Expressions (Entry_Name)); Resolve (Index, Entry_Index_Type (Nam)); @@ -4026,7 +4298,6 @@ package body Sem_Res is Apply_Range_Check (Index, Actual_Index_Type (Nam)); end if; end if; - end Resolve_Entry; ------------------------ @@ -4044,6 +4315,11 @@ package body Sem_Res is Was_Over : Boolean; begin + -- We kill all checks here, because it does not seem worth the + -- effort to do anything better, an entry call is a big operation. + + Kill_All_Checks; + -- Processing of the name is similar for entry calls and protected -- operation calls. Once the entity is determined, we can complete -- the resolution of the actuals. @@ -4096,6 +4372,14 @@ package body Sem_Res is Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); end if; + -- We cannot in general check the maximum depth of protected entry + -- calls at compile time. But we can tell that any protected entry + -- call at all violates a specified nesting depth of zero. + + if Is_Protected_Type (Scope (Nam)) then + Check_Restriction (Max_Entry_Queue_Depth, N); + end if; + -- Use context type to disambiguate a protected function that can be -- called without actuals and that returns an array type, and where -- the argument list may be an indexing of the returned value. @@ -4135,11 +4419,13 @@ package body Sem_Res is end if; -- The operation name may have been overloaded. Order the actuals - -- according to the formals of the resolved entity. + -- according to the formals of the resolved entity, and set the + -- return type to that of the operation. if Was_Over then Normalize_Actuals (N, Nam, False, Norm_OK); pragma Assert (Norm_OK); + Set_Etype (N, Etype (Nam)); end if; Resolve_Actuals (N, Nam); @@ -4155,7 +4441,6 @@ package body Sem_Res is -- call where an entry call is expected. if Ekind (Nam) = E_Procedure then - if Nkind (Parent (N)) = N_Entry_Call_Alternative and then N = Entry_Call_Statement (Parent (N)) then @@ -4215,7 +4500,6 @@ package body Sem_Res is Establish_Transient_Scope (N, Sec_Stack => not Functions_Return_By_DSP_On_Target); end if; - end Resolve_Entry_Call; ------------------------- @@ -4330,9 +4614,19 @@ package body Sem_Res is Resolve (L, T); Resolve (R, T); + + if Warn_On_Redundant_Constructs + and then Comes_From_Source (N) + and then Is_Entity_Name (R) + and then Entity (R) = Standard_True + and then Comes_From_Source (R) + then + Error_Msg_N ("comparison with True is redundant?", R); + end if; + Check_Unset_Reference (L); Check_Unset_Reference (R); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, T); -- If this is an inequality, it may be the implicit inequality -- created for a user-defined operation, in which case the corres- @@ -4391,7 +4685,7 @@ package body Sem_Res is Set_Etype (N, Designated_Type (It.Typ)); else - Resolve (P, Etype (P)); + Resolve (P); end if; if Is_Access_Type (Etype (P)) then @@ -4529,7 +4823,6 @@ package body Sem_Res is end if; Eval_Indexed_Component (N); - end Resolve_Indexed_Component; ----------------------------- @@ -4547,9 +4840,10 @@ package body Sem_Res is --------------------------------- procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is - Op : Entity_Id; - Arg1 : Node_Id := Left_Opnd (N); - Arg2 : Node_Id := Right_Opnd (N); + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; begin Op := Entity (N); @@ -4561,17 +4855,94 @@ package body Sem_Res is Set_Entity (N, Op); - if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then - Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1)); - Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2)); + -- If the operand type is private, rewrite with suitable + -- conversions on the operands and the result, to expose + -- the proper underlying numeric type. - Analyze (Left_Opnd (N)); - Analyze (Right_Opnd (N)); - end if; + if Is_Private_Type (Typ) then + Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N)); + + if Nkind (N) = N_Op_Expon then + Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); + else + Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); + end if; + + Save_Interps (Left_Opnd (N), Expression (Arg1)); + Save_Interps (Right_Opnd (N), Expression (Arg2)); - Resolve_Arithmetic_Op (N, Typ); + Set_Left_Opnd (N, Arg1); + Set_Right_Opnd (N, Arg2); + + Set_Etype (N, Btyp); + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Resolve (N, Typ); + + elsif Typ /= Etype (Left_Opnd (N)) + or else Typ /= Etype (Right_Opnd (N)) + then + -- Add explicit conversion where needed, and save interpretations + -- if operands are overloaded. + + Arg1 := Convert_To (Typ, Left_Opnd (N)); + Arg2 := Convert_To (Typ, Right_Opnd (N)); + + if Nkind (Arg1) = N_Type_Conversion then + Save_Interps (Left_Opnd (N), Expression (Arg1)); + end if; + + if Nkind (Arg2) = N_Type_Conversion then + Save_Interps (Right_Opnd (N), Expression (Arg2)); + end if; + + Rewrite (Left_Opnd (N), Arg1); + Rewrite (Right_Opnd (N), Arg2); + Analyze (Arg1); + Analyze (Arg2); + Resolve_Arithmetic_Op (N, Typ); + + else + Resolve_Arithmetic_Op (N, Typ); + end if; end Resolve_Intrinsic_Operator; + -------------------------------------- + -- Resolve_Intrinsic_Unary_Operator -- + -------------------------------------- + + procedure Resolve_Intrinsic_Unary_Operator + (N : Node_Id; + Typ : Entity_Id) + is + Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); + Op : Entity_Id; + Arg2 : Node_Id; + + begin + Op := Entity (N); + + while Scope (Op) /= Standard_Standard loop + Op := Homonym (Op); + pragma Assert (Present (Op)); + end loop; + + Set_Entity (N, Op); + + if Is_Private_Type (Typ) then + Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); + Save_Interps (Right_Opnd (N), Expression (Arg2)); + + Set_Right_Opnd (N, Arg2); + + Set_Etype (N, Btyp); + Rewrite (N, Unchecked_Convert_To (Typ, N)); + Resolve (N, Typ); + + else + Resolve_Unary_Op (N, Typ); + end if; + end Resolve_Intrinsic_Unary_Operator; + ------------------------ -- Resolve_Logical_Op -- ------------------------ @@ -4620,7 +4991,7 @@ package body Sem_Res is Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Logical_Op (N); end Resolve_Logical_Op; @@ -4798,6 +5169,10 @@ package body Sem_Res is Resolve (Arg, Component_Type (Typ)); + if Nkind (Arg) = N_String_Literal then + Set_Etype (Arg, Component_Type (Typ)); + end if; + if Arg = Left_Opnd (N) then Set_Is_Component_Left_Opnd (N); else @@ -4819,6 +5194,7 @@ package body Sem_Res is if Is_Limited_Composite (Btyp) then Error_Msg_N ("concatenation not available for limited array", N); + Explain_Limited_Type (Btyp, N); end if; -- If the operands are themselves concatenations, resolve them as @@ -4845,7 +5221,7 @@ package body Sem_Res is (Op2, Is_Component_Right_Opnd (N)); end if; - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, Typ); if Is_String_Type (Typ) then Eval_Concatenation (N); @@ -4880,6 +5256,15 @@ package body Sem_Res is return; end if; + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Operator (N, Typ); + return; + end if; + if Etype (Left_Opnd (N)) = Universal_Integer or else Etype (Left_Opnd (N)) = Universal_Real then @@ -4896,7 +5281,7 @@ package body Sem_Res is Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Op_Expon (N); -- Set overflow checking bit. Much cleverer code needed here eventually @@ -4905,10 +5290,9 @@ package body Sem_Res is if Nkind (N) in N_Op then if not Overflow_Checks_Suppressed (Etype (N)) then - Set_Do_Overflow_Check (N, True); + Enable_Overflow_Check (N); end if; end if; - end Resolve_Op_Expon; -------------------- @@ -4971,9 +5355,7 @@ package body Sem_Res is Set_Etype (N, Any_Type); return; - elsif (Typ = Universal_Integer - or else Typ = Any_Modular) - then + elsif Typ = Universal_Integer or else Typ = Any_Modular then if Parent_Is_Boolean then Error_Msg_N ("operand of not must be enclosed in parentheses", @@ -4996,7 +5378,7 @@ package body Sem_Res is Resolve (Right_Opnd (N), B_Typ); Check_Unset_Reference (Right_Opnd (N)); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Op_Not (N); end if; end Resolve_Op_Not; @@ -5077,6 +5459,21 @@ package body Sem_Res is Check_Non_Static_Context (L); Check_Non_Static_Context (H); + -- If bounds are static, constant-fold them, so size computations + -- are identical between front-end and back-end. Do not perform this + -- transformation while analyzing generic units, as type information + -- would then be lost when reanalyzing the constant node in the + -- instance. + + if Is_Discrete_Type (Typ) and then Expander_Active then + if Is_OK_Static_Expression (L) then + Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L)); + end if; + + if Is_OK_Static_Expression (H) then + Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H)); + end if; + end if; end Resolve_Range; -------------------------- @@ -5165,7 +5562,7 @@ package body Sem_Res is -- result in transformations of normal assignments into reference -- sequences that otherwise fail to notice the modification. - if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then + if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then Note_Possible_Modification (P); end if; end Resolve_Reference; @@ -5188,7 +5585,7 @@ package body Sem_Res is function Init_Component return Boolean; -- Check whether this is the initialization of a component within an - -- init_proc (by assignment or call to another init_proc). If true, + -- init proc (by assignment or call to another init proc). If true, -- there is no need for a discriminant check. -------------------- @@ -5272,7 +5669,6 @@ package body Sem_Res is end if; Get_Next_Interp (I, It); - end loop Search; Resolve (P, It1.Typ); @@ -5280,7 +5676,7 @@ package body Sem_Res is Set_Entity (S, Comp1); else - -- Resolve prefix with its type. + -- Resolve prefix with its type Resolve (P, T); end if; @@ -5295,6 +5691,9 @@ package body Sem_Res is end if; if Has_Discriminants (T) + and then (Ekind (Entity (S)) = E_Component + or else + Ekind (Entity (S)) = E_Discriminant) and then Present (Original_Record_Component (Entity (S))) and then Ekind (Original_Record_Component (Entity (S))) = E_Component and then Present (Discriminant_Checking_Func @@ -5315,6 +5714,7 @@ package body Sem_Res is if Nkind (P) = N_Type_Conversion and then Ekind (Entity (S)) = E_Discriminant + and then Is_Discrete_Type (Typ) then Set_Etype (N, Base_Type (Typ)); end if; @@ -5344,7 +5744,7 @@ package body Sem_Res is Check_Unset_Reference (R); Set_Etype (N, B_Typ); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Shift (N); end Resolve_Shift; @@ -5460,7 +5860,6 @@ package body Sem_Res is Set_Slice_Subtype (N); Eval_Slice (N); - end Resolve_Slice; ---------------------------- @@ -5655,7 +6054,7 @@ package body Sem_Res is -- heavy artillery for this situation, but it is hard work to avoid. declare - Lits : List_Id := New_List; + Lits : constant List_Id := New_List; P : Source_Ptr := Loc + 1; C : Char_Code; @@ -5710,6 +6109,8 @@ package body Sem_Res is Operand : Node_Id; Opnd_Type : Entity_Id; Rop : Node_Id; + Orig_N : Node_Id; + Orig_T : Node_Id; begin Operand := Expression (N); @@ -5764,7 +6165,7 @@ package body Sem_Res is end if; Opnd_Type := Etype (Operand); - Resolve (Operand, Opnd_Type); + Resolve (Operand); -- Note: we do the Eval_Type_Conversion call before applying the -- required checks for a subtype conversion. This is important, @@ -5792,16 +6193,34 @@ package body Sem_Res is end if; -- Issue warning for conversion of simple object to its own type + -- We have to test the original nodes, since they may have been + -- rewritten by various optimizations. + + Orig_N := Original_Node (N); if Warn_On_Redundant_Constructs - and then Comes_From_Source (N) - and then Nkind (N) = N_Type_Conversion - and then Is_Entity_Name (Expression (N)) - and then Etype (Entity (Expression (N))) = Target_Type + and then Comes_From_Source (Orig_N) + and then Nkind (Orig_N) = N_Type_Conversion then - Error_Msg_NE - ("?useless conversion, & has this type", - N, Entity (Expression (N))); + Orig_N := Original_Node (Expression (Orig_N)); + Orig_T := Target_Type; + + -- If the node is part of a larger expression, the Target_Type + -- may not be the original type of the node if the context is a + -- condition. Recover original type to see if conversion is needed. + + if Is_Boolean_Type (Orig_T) + and then Nkind (Parent (N)) in N_Op + then + Orig_T := Etype (Parent (N)); + end if; + + if Is_Entity_Name (Orig_N) + and then Etype (Entity (Orig_N)) = Orig_T + then + Error_Msg_NE + ("?useless conversion, & has this type", N, Entity (Orig_N)); + end if; end if; end Resolve_Type_Conversion; @@ -5810,30 +6229,57 @@ package body Sem_Res is ---------------------- procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is - B_Typ : Entity_Id := Base_Type (Typ); - R : constant Node_Id := Right_Opnd (N); + B_Typ : constant Entity_Id := Base_Type (Typ); + R : constant Node_Id := Right_Opnd (N); + OK : Boolean; + Lo : Uint; + Hi : Uint; begin + -- Generate warning for expressions like abs (x mod 2) + + if Warn_On_Redundant_Constructs + and then Nkind (N) = N_Op_Abs + then + Determine_Range (Right_Opnd (N), OK, Lo, Hi); + + if OK and then Hi >= Lo and then Lo >= 0 then + Error_Msg_N + ("?abs applied to known non-negative value has no effect", N); + end if; + end if; + -- Generate warning for expressions like -5 mod 3 if Paren_Count (N) = 0 and then Nkind (N) = N_Op_Minus and then Nkind (Right_Opnd (N)) = N_Op_Mod + and then Comes_From_Source (N) then Error_Msg_N ("?unary minus expression should be parenthesized here", N); end if; + if Comes_From_Source (N) + and then Ekind (Entity (N)) = E_Function + and then Is_Imported (Entity (N)) + and then Is_Intrinsic_Subprogram (Entity (N)) + then + Resolve_Intrinsic_Unary_Operator (N, Typ); + return; + end if; + if Etype (R) = Universal_Integer - or else Etype (R) = Universal_Real + or else Etype (R) = Universal_Real then Check_For_Visible_Operator (N, B_Typ); end if; Set_Etype (N, B_Typ); Resolve (R, B_Typ); + Check_Unset_Reference (R); - Generate_Operator_Reference (N); + Generate_Operator_Reference (N, B_Typ); Eval_Unary_Op (N); -- Set overflow checking bit. Much cleverer code needed here eventually @@ -5842,10 +6288,9 @@ package body Sem_Res is if Nkind (N) in N_Op then if not Overflow_Checks_Suppressed (Etype (N)) then - Set_Do_Overflow_Check (N, True); + Enable_Overflow_Check (N); end if; end if; - end Resolve_Unary_Op; ---------------------------------- @@ -5887,8 +6332,8 @@ package body Sem_Res is ------------------------------ procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is - Loc : Source_Ptr := Sloc (N); - Actuals : List_Id := New_List; + Loc : constant Source_Ptr := Sloc (N); + Actuals : constant List_Id := New_List; New_N : Node_Id; begin @@ -5919,17 +6364,21 @@ package body Sem_Res is Op_Node : Node_Id; begin - if Chars (N) /= Nam then - - -- Rewrite the operator node using the real operator, not its - -- renaming. + -- Rewrite the operator node using the real operator, not its + -- renaming. Exclude user-defined intrinsic operations, which + -- are treated separately. + if Ekind (Op) /= E_Function then Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); Set_Chars (Op_Node, Nam); Set_Etype (Op_Node, Etype (N)); Set_Entity (Op_Node, Op); Set_Right_Opnd (Op_Node, Right_Opnd (N)); + -- Indicate that both the original entity and its renaming + -- are referenced at this point. + + Generate_Reference (Entity (N), N); Generate_Reference (Op, N); if Is_Binary then @@ -5953,8 +6402,8 @@ package body Sem_Res is procedure Set_Slice_Subtype (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); + Index_List : constant List_Id := New_List; Index : Node_Id; - Index_List : List_Id := New_List; Index_Subtype : Entity_Id; Index_Type : Entity_Id; Slice_Subtype : Entity_Id; @@ -6072,10 +6521,9 @@ package body Sem_Res is T1 := Standard_Duration; - Scop := Current_Scope; - -- Look for fixed-point types in enclosing scopes. + Scop := Current_Scope; while Scop /= Standard_Standard loop T2 := First_Entity (Scop); @@ -6103,7 +6551,6 @@ package body Sem_Res is Item := First (Context_Items (Cunit (Current_Sem_Unit))); while Present (Item) loop - if Nkind (Item) = N_With_Clause then Scop := Entity (Name (Item)); T2 := First_Entity (Scop); @@ -6149,7 +6596,7 @@ package body Sem_Res is Operand : Node_Id) return Boolean is - Target_Type : Entity_Id := Base_Type (Target); + Target_Type : constant Entity_Id := Base_Type (Target); Opnd_Type : Entity_Id := Etype (Operand); function Conversion_Check @@ -6315,14 +6762,16 @@ package body Sem_Res is else declare - Target_Index : Node_Id := First_Index (Target_Type); - Opnd_Index : Node_Id := First_Index (Opnd_Type); + Target_Index : Node_Id := First_Index (Target_Type); + Opnd_Index : Node_Id := First_Index (Opnd_Type); Target_Index_Type : Entity_Id; Opnd_Index_Type : Entity_Id; - Target_Comp_Type : Entity_Id := Component_Type (Target_Type); - Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type); + Target_Comp_Type : constant Entity_Id := + Component_Type (Target_Type); + Opnd_Comp_Type : constant Entity_Id := + Component_Type (Opnd_Type); begin while Present (Target_Index) and then Present (Opnd_Index) loop |
