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/a-except.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/a-except.adb')
| -rw-r--r-- | gcc/ada/a-except.adb | 2458 |
1 files changed, 600 insertions, 1858 deletions
diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 30393145309..d6a6f5ff3c6 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.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- -- @@ -35,20 +35,14 @@ pragma Polling (Off); -- We must turn polling off for this unit, because otherwise we get -- elaboration circularities with System.Exception_Tables. -with Ada.Unchecked_Deallocation; - -with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; +pragma Warnings (Off); +-- Since several constructs give warnings in 3.14a1, including unreferenced +-- variables and pragma Unreferenced itself. with System; use System; -with System.Exception_Table; use System.Exception_Table; -with System.Exceptions; use System.Exceptions; with System.Standard_Library; use System.Standard_Library; -with System.Storage_Elements; use System.Storage_Elements; with System.Soft_Links; use System.Soft_Links; with System.Machine_State_Operations; use System.Machine_State_Operations; -with System.Traceback; - -with Unchecked_Conversion; package body Ada.Exceptions is @@ -61,145 +55,14 @@ package body Ada.Exceptions is -- we are in big trouble. If an exceptional situation does occur, better -- that it not be raised, since raising it can cause confusing chaos. - type Subprogram_Descriptor_List_Ptr is - access all Subprogram_Descriptor_List; - - Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr; - -- This location is initialized by Register_Exceptions to point to a - -- list of pointers to procedure descriptors, sorted into ascending - -- order of PC addresses. - -- - -- Note that SDP_Table_Build is called *before* this unit (or any - -- other unit) is elaborated. That's important, because exceptions can - -- and do occur during elaboration of units, and must be handled during - -- elaboration. This means that we are counting on the fact that the - -- initialization of Subprogram_Descriptors to null is done by the - -- load process and NOT by an explicit assignment during elaboration. - - Num_Subprogram_Descriptors : Natural; - -- Number of subprogram descriptors, the useful descriptors are stored - -- in Subprogram_Descriptors (1 .. Num_Subprogram_Descriptors). There - -- can be unused entries at the end of the array due to elimination of - -- duplicated entries (which can arise from use of pragma Import). - - Exception_Tracebacks : Integer; - pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); - -- Boolean indicating whether tracebacks should be stored in exception - -- occurrences. - Zero_Cost_Exceptions : Integer; pragma Import (C, Zero_Cost_Exceptions, "__gl_zero_cost_exceptions"); -- Boolean indicating if we are handling exceptions using a zero cost -- mechanism. -- - -- ??? We currently have two alternatives for this scheme : one using - -- front-end tables and one using back-end tables. The former is known to - -- only work for GNAT3 and the latter is known to only work for GNAT5. - -- Both are present in this implementation and it would be good to have - -- separate bodies at some point. - -- -- Note that although we currently do not support it, the GCC3 back-end -- tables are also potentially useable for setjmp/longjmp processing. - Nline : constant String := String' (1 => ASCII.LF); - -- Convenient shortcut - - ------------------------------------------------ - -- Entities to interface with the GCC runtime -- - ------------------------------------------------ - - -- These come from "C++ ABI for Itanium : Exception handling", which is - -- the reference for GCC. They are used only when we are relying on - -- back-end tables for exception propagation, which in turn is currenly - -- only the case for Zero_Cost_Exceptions in GNAT5. - - -- Return codes from the GCC runtime functions used to propagate - -- an exception. - - type Unwind_Reason_Code is - (URC_NO_REASON, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_PHASE2_ERROR, - URC_PHASE1_ERROR, - URC_NORMAL_STOP, - URC_END_OF_STACK, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND); - - -- ??? pragma Unreferenced is unknown until 3.15, so we need to disable - -- warnings around it to fix the bootstrap path. - - pragma Warnings (Off); - pragma Unreferenced - (URC_NO_REASON, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_PHASE2_ERROR, - URC_PHASE1_ERROR, - URC_NORMAL_STOP, - URC_END_OF_STACK, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND); - pragma Warnings (On); - - pragma Convention (C, Unwind_Reason_Code); - - -- Mandatory common header for any exception object handled by the - -- GCC unwinding runtime. - - subtype Exception_Class is String (1 .. 8); - - GNAT_Exception_Class : constant Exception_Class - := "GNU" & ASCII.NUL & "Ada" & ASCII.NUL; - - type Unwind_Exception is record - Class : Exception_Class := GNAT_Exception_Class; - Cleanup : System.Address := System.Null_Address; - Private1 : Integer; - Private2 : Integer; - end record; - - pragma Convention (C, Unwind_Exception); - - for Unwind_Exception'Alignment use Standard'Maximum_Alignment; - - -- A GNAT exception object to be dealt with by the personality routine - -- called by the GCC unwinding runtime. This structure shall match the - -- one in raise.c and is currently experimental as it might be merged - -- with the GNAT runtime definition some day. - - type GNAT_GCC_Exception is record - Header : Unwind_Exception; - -- Exception header first, as required by the ABI. - - Id : Exception_Id; - -- Usual Exception identifier - - Handled_By_Others : Boolean; - -- Is this exception handled by "when others" ? - - Has_Cleanup : Boolean; - -- Did we see any at-end handler while walking up the stack - -- searching for a handler ? This is used to determine if we - -- start the propagation again after having tried once without - -- finding a true handler for the exception. - - Select_Cleanups : Boolean; - -- Do we consider at-end handlers as legitimate handlers for the - -- exception ? This is used to control the propagation process - -- as described in Raise_Current_Excep. - end record; - - pragma Convention (C, GNAT_GCC_Exception); - - -- GCC runtime functions used - - function Unwind_RaiseException - (E : access GNAT_GCC_Exception) - return Unwind_Reason_Code; - pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); - ----------------------- -- Local Subprograms -- ----------------------- @@ -209,64 +72,238 @@ package body Ada.Exceptions is -- technically visible in the Ada sense. procedure AAA; - -- Mark start of procedures in this unit - procedure ZZZ; - -- Mark end of procedures in this package - - function Address_Image (A : System.Address) return String; - -- Returns at string of the form 0xhhhhhhhhh for 32-bit addresses - -- or 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are - -- in lower case. + -- Mark start and end of procedures in this package + -- + -- The AAA and ZZZ procedures are used to provide exclusion bounds in + -- calls to Call_Chain at exception raise points from this unit. The + -- purpose is to arrange for the exception tracebacks not to include + -- frames from routines involved in the raise process, as these are + -- meaningless from the user's standpoint. + -- + -- For these bounds to be meaningful, we need to ensure that the object + -- code for the routines involved in processing a raise is located after + -- the object code for AAA and before the object code for ZZZ. This will + -- indeed be the case as long as the following rules are respected: + -- + -- 1) The bodies of the subprograms involved in processing a raise + -- are located after the body of AAA and before the body of ZZZ. + -- + -- 2) No pragma Inline applies to any of these subprograms, as this + -- could delay the corresponding assembly output until the end of + -- the unit. + + Code_Address_For_AAA, Code_Address_For_ZZZ : System.Address; + -- Used to represent addresses really inside the code range for AAA and + -- ZZZ, initialized to the address of a label inside the corresponding + -- procedure. This is initialization takes place inside the procedures + -- themselves, which are called as part of the elaboration code. + -- + -- We are doing this instead of merely using Proc'Address because on some + -- platforms the latter does not yield the address we want, but the + -- address of a stub or of a descriptor instead. This is the case at least + -- on Alpha-VMS and PA-HPUX. procedure Call_Chain (Excep : EOA); -- Store up to Max_Tracebacks in Excep, corresponding to the current -- call chain. - procedure Free - is new Ada.Unchecked_Deallocation - (Subprogram_Descriptor_List, Subprogram_Descriptor_List_Ptr); - procedure Process_Raise_Exception (E : Exception_Id; From_Signal_Handler : Boolean); - pragma Inline (Process_Raise_Exception); pragma No_Return (Process_Raise_Exception); -- This is the lowest level raise routine. It raises the exception -- referenced by Current_Excep.all in the TSD, without deferring abort -- (the caller must ensure that abort is deferred on entry). -- - -- This is actually the common implementation for Raise_Current_Excep and - -- Raise_From_Signal_Handler, with a couple of operations inhibited when - -- called from the latter. The origin of the call is indicated by the + -- This is the common implementation for Raise_Current_Excep and + -- Raise_From_Signal_Handler. The origin of the call is indicated by the -- From_Signal_Handler argument. - -- - -- The Inline pragma is there for efficiency reasons. - - procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State); - pragma No_Return (Propagate_Exception_With_FE_Support); - -- This procedure propagates the exception represented by the occurrence - -- referenced by Current_Excep in the TSD for the current task. M is the - -- initial machine state, representing the site of the exception raise - -- operation. - -- - -- The procedure searches the front end exception tables for an applicable - -- handler, calling Pop_Frame as needed. If and when it locates an - -- applicable handler, Enter_Handler is called to actually enter this - -- handler. If the search is unable to locate an applicable handler, - -- execution is terminated by calling Unhandled_Exception_Terminate. - - procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State); - pragma No_Return (Propagate_Exception_With_GCC_Support); - -- This procedure propagates the exception represented by the occurrence - -- referenced by Current_Excep in the TSD for the current task. M is the - -- initial machine state, representing the site of the exception raise - -- operation. It is currently not used and is there for the purpose of - -- interface consistency against Propagate_Exception_With_FE_Support. - -- - -- The procedure builds an object suitable for the libgcc processing and - -- calls Unwind_RaiseException to actually throw, taking care of handling - -- the two phase scheme it implements. + + package Exception_Data is + + ---------------------------------- + -- Exception messages routines -- + ---------------------------------- + + procedure Set_Exception_C_Msg + (Id : Exception_Id; + Msg1 : Big_String_Ptr; + Line : Integer := 0; + Msg2 : Big_String_Ptr := null); + -- This routine is called to setup the exception referenced by the + -- Current_Excep field in the TSD to contain the indicated Id value + -- and message. Msg1 is a null terminated string which is generated + -- as the exception message. If line is non-zero, then a colon and + -- the decimal representation of this integer is appended to the + -- message. When Msg2 is non-null, a space and this additional null + -- terminated string is added to the message. + + procedure Set_Exception_Msg + (Id : Exception_Id; + Message : String); + -- This routine is called to setup the exception referenced by the + -- Current_Excep field in the TSD to contain the indicated Id value + -- and message. Message is a string which is generated as the + -- exception message. + + -------------------------------------- + -- Exception information subprogram -- + -------------------------------------- + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- exception name (as in Exception_Name) + -- message (or a null line if no message) + -- PID=nnnn + -- 0xyyyyyyyy 0xyyyyyyyy ... + -- + -- The lines are separated by a ASCII.LF character + -- The nnnn is the partition Id given as decimal digits. + -- The 0x... line represents traceback program counter locations, + -- in order with the first one being the exception location. + + --------------------------------------- + -- Exception backtracing subprograms -- + --------------------------------------- + + -- What is automatically output when exception tracing is on basically + -- corresponds to the usual exception information, but with the call + -- chain backtrace possibly tailored by a backtrace decorator. Modifying + -- Exception_Information itself is not a good idea because the decorated + -- output is completely out of control and would break all our code + -- related to the streaming of exceptions. + -- + -- We then provide an alternative function to Exception_Information to + -- compute the possibly tailored output, which is equivalent if no + -- decorator is currently set. + + function Tailored_Exception_Information + (X : Exception_Occurrence) + return String; + -- Exception information to be output in the case of automatic tracing + -- requested through GNAT.Exception_Traces. + -- + -- This is the same as Exception_Information if no backtrace decorator + -- is currently in place. Otherwise, this is Exception_Information with + -- the call chain raw addresses replaced by the result of a call to the + -- current decorator provided with the call chain addresses. + + pragma Export + (Ada, Tailored_Exception_Information, + "__gnat_tailored_exception_information"); + -- This function is used within this package but also from within + -- System.Tasking.Stages. + -- + -- The output of Exception_Information and + -- Tailored_Exception_Information share a common part which was + -- formerly built using local procedures within + -- Exception_Information. These procedures have been extracted + -- from their original place to be available to + -- Tailored_Exception_Information also. + -- + -- Each of these procedures appends some input to an + -- information string currently being built. The Ptr argument + -- represents the last position in this string at which a + -- character has been written. + + procedure Tailored_Exception_Information + (X : Exception_Occurrence; + Buff : in out String; + Last : in out Integer); + -- Procedural version of the above function. Instead of returning the + -- result, this one is put in Buff (Buff'first .. Buff'first + Last) + -- And what happens on overflow ??? + + end Exception_Data; + + package Exception_Traces is + + use Exception_Data; + -- Imports Tailored_Exception_Information + + ---------------------------------------------- + -- Run-Time Exception Notification Routines -- + ---------------------------------------------- + + -- These subprograms provide a common run-time interface to trigger the + -- actions required when an exception is about to be propagated (e.g. + -- user specified actions or output of exception information). They are + -- exported to be usable by the Ada exception handling personality + -- routine when the GCC 3 mechanism is used. + + procedure Notify_Handled_Exception; + pragma Export (C, Notify_Handled_Exception, + "__gnat_notify_handled_exception"); + -- This routine is called for a handled occurrence is about to be + -- propagated. + + procedure Notify_Unhandled_Exception; + pragma Export (C, Notify_Unhandled_Exception, + "__gnat_notify_unhandled_exception"); + -- This routine is called when an unhandled occurrence is about to be + -- propagated. + + procedure Unhandled_Exception_Terminate; + pragma No_Return (Unhandled_Exception_Terminate); + -- This procedure is called to terminate execution following an + -- unhandled exception. The exception information, including + -- traceback if available is output, and execution is then + -- terminated. Note that at the point where this routine is + -- called, the stack has typically been destroyed. + + end Exception_Traces; + + package Exception_Propagation is + + use Exception_Traces; + -- Imports Notify_Unhandled_Exception and + -- Unhandled_Exception_Terminate + + ------------------------------------ + -- Exception propagation routines -- + ------------------------------------ + + procedure Setup_Exception + (Excep : EOA; + Current : EOA; + Reraised : Boolean := False); + -- Perform the necessary operations to prepare the propagation of Excep + -- in a task where Current is the current occurrence. Excep is assumed + -- to be a valid (non null) pointer. + -- + -- This should be called before any (re-)setting of the current + -- occurrence. Any such (re-)setting shall take care *not* to clobber + -- the Private_Data component. + -- + -- Having Current provided as an argument (instead of retrieving it via + -- Get_Current_Excep internally) is required to allow one task to setup + -- an exception for another task, which is used by Transfer_Occurrence. + + procedure Propagate_Exception (From_Signal_Handler : Boolean); + pragma No_Return (Propagate_Exception); + -- This procedure propagates the exception represented by the occurrence + -- referenced by Current_Excep in the TSD for the current task. + + end Exception_Propagation; + + package Stream_Attributes is + + -------------------------------- + -- Stream attributes routines -- + -------------------------------- + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + -- Functions for implementing Exception_Id stream attributes + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + -- Functions for implementing Exception_Occurrence stream + -- attributes + + end Stream_Attributes; procedure Raise_Current_Excep (E : Exception_Id); pragma No_Return (Raise_Current_Excep); @@ -280,7 +317,8 @@ package body Ada.Exceptions is procedure Raise_Exception_No_Defer (E : Exception_Id; Message : String := ""); - pragma Export (Ada, Raise_Exception_No_Defer, + pragma Export + (Ada, Raise_Exception_No_Defer, "ada__exceptions__raise_exception_no_defer"); pragma No_Return (Raise_Exception_No_Defer); -- Similar to Raise_Exception, but with no abort deferral @@ -293,24 +331,30 @@ package body Ada.Exceptions is -- exception occurrence referenced by the Current_Excep in the TSD. -- Abort is deferred before the raise call. - procedure Raise_With_Location - (E : Exception_Id; - F : Big_String_Ptr; - L : Integer); - pragma No_Return (Raise_With_Location); - -- Raise an exception with given exception id value. A filename and line - -- number is associated with the raise and is stored in the exception - -- occurrence. + procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean); + pragma No_Return (Raise_With_Msg); + -- Similar to above, with an extra parameter to indicate wether + -- Setup_Exception has been called already. + + procedure Raise_After_Setup (E : Exception_Id); + pragma No_Return (Raise_After_Setup); + pragma Export (C, Raise_After_Setup, "__gnat_raise_after_setup"); + -- Wrapper to Raise_With_Msg and Setup set to True. + -- + -- This is called by System.Tasking.Entry_Calls.Check_Exception when an + -- exception has occured during an entry call. The exception to propagate + -- has been setup and initialized via Transfer_Occurrence in this case. procedure Raise_With_Location_And_Msg (E : Exception_Id; F : Big_String_Ptr; L : Integer; - M : Big_String_Ptr); + M : Big_String_Ptr := null); pragma No_Return (Raise_With_Location_And_Msg); -- Raise an exception with given exception id value. A filename and line -- number is associated with the raise and is stored in the exception - -- occurrence and in addition a string message M is appended to this. + -- occurrence and in addition a string message M is appended to + -- this (if M is not null). procedure Raise_Constraint_Error (File : Big_String_Ptr; @@ -376,14 +420,12 @@ package body Ada.Exceptions is -- | | | | | -- +--+ +--+ +---+ | +---+ -- | | | | | - -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc R_W_C_Msg - -- | | | | | | - -- +------------+ | +-----------+ +--+ +--+ | - -- | | | | | | - -- | | | Set_E_C_Msg(i) | - -- | | | | - -- | | | +--------------------------+ - -- | | | | + -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc + -- | | | | + -- +------------+ | +-----------+ +--+ + -- | | | | + -- | | | Set_E_C_Msg(i) + -- | | | -- Raise_Current_Excep procedure Reraise; @@ -393,67 +435,32 @@ package body Ada.Exceptions is -- the TSD (all fields of this exception occurrence are set). Abort -- is deferred before the reraise operation. - function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean; - -- Used in call to sort SDP table (SDP_Table_Build), compares two elements - - procedure SDP_Table_Sort_Move (From : Natural; To : Natural); - -- Used in call to sort SDP table (SDP_Table_Build), moves one element - - procedure Set_Exception_C_Msg - (Id : Exception_Id; - Msg1 : Big_String_Ptr; - Line : Integer := 0; - Msg2 : Big_String_Ptr := null); - -- This routine is called to setup the exception referenced by the - -- Current_Excep field in the TSD to contain the indicated Id value - -- and message. Msg1 is a null terminated string which is generated - -- as the exception message. If line is non-zero, then a colon and - -- the decimal representation of this integer is appended to the - -- message. When Msg2 is non-null, a space and this additional null - -- terminated string is added to the message. - - procedure To_Stderr (S : String); - pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); - -- Little routine to output string to stderr that is also used - -- in the tasking run time. - - procedure Unhandled_Exception_Terminate; - pragma No_Return (Unhandled_Exception_Terminate); - -- This procedure is called to terminate execution following an unhandled - -- exception. The exception information, including traceback if available - -- is output, and execution is then terminated. Note that at the point - -- where this routine is called, the stack has typically been destroyed + -- Save_Occurrence variations: As the management of the private data + -- attached to occurrences is delicate, wether or not pointers to such + -- data has to be copied in various situations is better made explicit. + -- The following procedures provide an internal interface to help making + -- this explicit. - --------------------------------- - -- Debugger Interface Routines -- - --------------------------------- + procedure Save_Occurrence_And_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + -- Copy all the components of Source to Target as well as the + -- Private_Data pointer. - -- The routines here are null routines that normally have no effect. - -- they are provided for the debugger to place breakpoints on their - -- entry points to get control on an exception. - - procedure Notify_Exception - (Id : Exception_Id; - Handler : Code_Loc; - Is_Others : Boolean); - pragma Export (C, Notify_Exception, "__gnat_notify_exception"); - -- This routine is called whenever an exception is signalled. The Id - -- parameter is the Exception_Id of the exception being raised. The - -- second parameter Handler is Null_Loc if the exception is unhandled, - -- and is otherwise the entry point of the handler that will handle - -- the exception. Is_Others is True if the handler is an others handler - -- and False otherwise. In the unhandled exception case, if possible - -- (and certainly if zero cost exception handling is active), the - -- stack is still intact when this procedure is called. Note that this - -- routine is entered before any finalization handlers are entered if - -- the exception is unhandled by a "real" exception handler. - - procedure Unhandled_Exception; - pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception"); - -- This routine is called in addition to Notify_Exception in the - -- unhandled exception case. The fact that there are two routines - -- which are somewhat redundant is historical. Notify_Exception - -- certainly is complete enough, but GDB still uses this routine. + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + -- Copy all the components of Source to Target, except the + -- Private_Data pointer. + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence); + pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + -- Called from System.Tasking.RendezVous.Exceptional_Complete_RendezVous + -- to setup Target from Source as an exception to be propagated in the + -- caller task. Target is expected to be a pointer to the fixed TSD + -- occurrence for this task. ----------------------------- -- Run-Time Check Routines -- @@ -551,10 +558,10 @@ package body Ada.Exceptions is Rmsg_14 : constant String := "all guards closed" & NUL; Rmsg_15 : constant String := "duplicated entry address" & NUL; Rmsg_16 : constant String := "explicit raise" & NUL; - Rmsg_17 : constant String := "finalize raised exception" & NUL; - Rmsg_18 : constant String := "invalid data" & NUL; - Rmsg_19 : constant String := "misaligned address value" & NUL; - Rmsg_20 : constant String := "missing return" & NUL; + Rmsg_17 : constant String := "finalize/adjust raised exception" & NUL; + Rmsg_18 : constant String := "misaligned address value" & NUL; + Rmsg_19 : constant String := "missing return" & NUL; + Rmsg_20 : constant String := "overlaid controlled object" & NUL; Rmsg_21 : constant String := "potentially blocking operation" & NUL; Rmsg_22 : constant String := "stubbed subprogram called" & NUL; Rmsg_23 : constant String := "unchecked union restriction" & NUL; @@ -564,302 +571,6 @@ package body Ada.Exceptions is Rmsg_27 : constant String := "object too large" & NUL; Rmsg_28 : constant String := "restriction violation" & NUL; - -------------------------------------- - -- Calls to Run-Time Check Routines -- - -------------------------------------- - - procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); - end Rcheck_00; - - procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); - end Rcheck_01; - - procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); - end Rcheck_02; - - procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); - end Rcheck_03; - - procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); - end Rcheck_04; - - procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); - end Rcheck_05; - - procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); - end Rcheck_06; - - procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); - end Rcheck_07; - - procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); - end Rcheck_08; - - procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); - end Rcheck_09; - - procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); - end Rcheck_10; - - procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); - end Rcheck_11; - - procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); - end Rcheck_12; - - procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); - end Rcheck_13; - - procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); - end Rcheck_14; - - procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); - end Rcheck_15; - - procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); - end Rcheck_16; - - procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); - end Rcheck_17; - - procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); - end Rcheck_18; - - procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); - end Rcheck_19; - - procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); - end Rcheck_20; - - procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); - end Rcheck_21; - - procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); - end Rcheck_22; - - procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); - end Rcheck_23; - - procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); - end Rcheck_24; - - procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); - end Rcheck_25; - - procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); - end Rcheck_26; - - procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); - end Rcheck_27; - - procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is - begin - Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); - end Rcheck_28; - - --------------------------------------- - -- Exception backtracing subprograms -- - --------------------------------------- - - -- What is automatically output when exception tracing is on basically - -- corresponds to the usual exception information, but with the call - -- chain backtrace possibly tailored by a backtrace decorator. Modifying - -- Exception_Information itself is not a good idea because the decorated - -- output is completely out of control and would break all our code - -- related to the streaming of exceptions. - -- - -- We then provide an alternative function to Exception_Information to - -- compute the possibly tailored output, which is equivalent if no - -- decorator is currently set : - - function Tailored_Exception_Information - (X : Exception_Occurrence) - return String; - -- Exception information to be output in the case of automatic tracing - -- requested through GNAT.Exception_Traces. - -- - -- This is the same as Exception_Information if no backtrace decorator - -- is currently in place. Otherwise, this is Exception_Information with - -- the call chain raw addresses replaced by the result of a call to the - -- current decorator provided with the call chain addresses. - - pragma Export - (Ada, Tailored_Exception_Information, - "__gnat_tailored_exception_information"); - -- This function is used within this package but also from within - -- System.Tasking.Stages. - -- - -- The output of Exception_Information and Tailored_Exception_Information - -- share a common part which was formerly built using local procedures - -- within Exception_Information. These procedures have been extracted from - -- their original place to be available to Tailored_Exception_Information - -- also. - -- - -- Each of these procedures appends some input to an information string - -- currently being built. The Ptr argument represents the last position - -- in this string at which a character has been written. - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural); - -- Append the image of N at the end of the provided information string - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural); - -- Append a LF at the end of the provided information string - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural); - -- Append a string at the end of the provided information string - - -- To build Exception_Information and Tailored_Exception_Information, - -- we then use three intermediate functions : - - function Basic_Exception_Information - (X : Exception_Occurrence) - return String; - -- Returns the basic exception information string associated with a - -- given exception occurrence. This is the common part shared by both - -- Exception_Information and Tailored_Exception_Infomation. - - function Basic_Exception_Traceback - (X : Exception_Occurrence) - return String; - -- Returns an image of the complete call chain associated with an - -- exception occurrence in its most basic form, that is as a raw sequence - -- of hexadecimal binary addresses. - - function Tailored_Exception_Traceback - (X : Exception_Occurrence) - return String; - -- Returns an image of the complete call chain associated with an - -- exception occurrence, either in its basic form if no decorator is - -- in place, or as formatted by the decorator otherwise. - - -- The overall organization of the exception information related code - -- is summarized below : - -- - -- Exception_Information - -- | - -- +-------+--------+ - -- | | - -- Basic_Exc_Info & Basic_Exc_Tback - -- - -- - -- Tailored_Exception_Information - -- | - -- +----------+----------+ - -- | | - -- Basic_Exc_Info & Tailored_Exc_Tback - -- | - -- +-----------+------------+ - -- | | - -- Basic_Exc_Tback Or Tback_Decorator - -- if no decorator set otherwise - - ---------------------------------------------- - -- Run-Time Exception Notification Routines -- - ---------------------------------------------- - - -- The notification routines described above are low level "handles" for - -- the debugger but what needs to be done at the notification points - -- always involves more than just calling one of these routines. The - -- routines below provide a common run-time interface for this purpose, - -- with variations depending on the handled/not handled status of the - -- occurrence. They are exported to be usable by the Ada exception - -- handling personality routine when the GCC 3 mechanism is used. - - procedure Notify_Handled_Exception - (Handler : Code_Loc; - Is_Others : Boolean; - Low_Notify : Boolean); - pragma Export (C, Notify_Handled_Exception, - "__gnat_notify_handled_exception"); - -- Routine to call when a handled occurrence is about to be propagated. - -- Low_Notify might be set to false to skip the low level debugger - -- notification, which is useful when the information it requires is - -- not available, like in the SJLJ case. - - procedure Notify_Unhandled_Exception (Id : Exception_Id); - pragma Export (C, Notify_Unhandled_Exception, - "__gnat_notify_unhandled_exception"); - -- Routine to call when an unhandled occurrence is about to be propagated. - - -------------------------------- - -- Import Run-Time C Routines -- - -------------------------------- - - -- The purpose of the following pragma Imports is to ensure that we - -- generate appropriate subprogram descriptors for all C routines in - -- the standard GNAT library that can raise exceptions. This ensures - -- that the exception propagation can properly find these routines - - pragma Warnings (Off); -- so old compiler does not complain - pragma Propagate_Exceptions; - - procedure Unhandled_Terminate; - pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - ----------------------- -- Polling Interface -- ----------------------- @@ -867,6 +578,7 @@ package body Ada.Exceptions is type Unsigned is mod 2 ** 32; Counter : Unsigned := 0; + pragma Warnings (Off, Counter); -- This counter is provided for convenience. It can be used in Poll to -- perform periodic but not systematic operations. @@ -884,213 +596,17 @@ package body Ada.Exceptions is procedure AAA is begin - null; + <<Start_Of_AAA>> + Code_Address_For_AAA := Start_Of_AAA'Address; end AAA; - ------------------- - -- Address_Image -- - ------------------- - - function Address_Image (A : Address) return String is - S : String (1 .. 18); - P : Natural; - N : Integer_Address; - - H : constant array (Integer range 0 .. 15) of Character := - "0123456789abcdef"; - begin - P := S'Last; - N := To_Integer (A); - while N /= 0 loop - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - end loop; - - S (P - 1) := '0'; - S (P) := 'x'; - return S (P - 1 .. S'Last); - end Address_Image; - - --------------------- - -- Append_Info_Nat -- - --------------------- - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural) - is - begin - if N > 9 then - Append_Info_Nat (N / 10, Info, Ptr); - end if; - - Ptr := Ptr + 1; - Info (Ptr) := Character'Val (Character'Pos ('0') + N mod 10); - end Append_Info_Nat; - - -------------------- - -- Append_Info_NL -- - -------------------- - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural) - is - begin - Ptr := Ptr + 1; - Info (Ptr) := ASCII.LF; - end Append_Info_NL; - - ------------------------ - -- Append_Info_String -- - ------------------------ - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural) - is - begin - Info (Ptr + 1 .. Ptr + S'Length) := S; - Ptr := Ptr + S'Length; - end Append_Info_String; - - --------------------------------- - -- Basic_Exception_Information -- - --------------------------------- - - function Basic_Exception_Information - (X : Exception_Occurrence) - return String - is - Name : constant String := Exception_Name (X); - Msg : constant String := Exception_Message (X); - -- Exception name and message that are going to be included in the - -- information to return, if not empty. - - Name_Len : constant Natural := Name'Length; - Msg_Len : constant Natural := Msg'Length; - -- Length of these strings, useful to compute the size of the string - -- we have to allocate for the complete result as well as in the body - -- of this procedure. - - Info_Maxlen : constant Natural := 50 + Name_Len + Msg_Len; - -- Maximum length of the information string we will build, with : - -- - -- 50 = 16 + 2 for the text associated with the name - -- + 9 + 2 for the text associated with the message - -- + 5 + 2 for the text associated with the pid - -- + 14 for the text image of the pid itself and a margin. - -- - -- This is indeed a maximum since some data may not appear at all if - -- not relevant. For example, nothing related to the exception message - -- will be there if this message is empty. - -- - -- WARNING : Do not forget to update these numbers if anything - -- involved in the computation changes. - - Info : String (1 .. Info_Maxlen); - -- Information string we are going to build, containing the common - -- part shared by Exc_Info and Tailored_Exc_Info. - - Ptr : Natural := 0; - - begin - -- Output exception name and message except for _ABORT_SIGNAL, where - -- these two lines are omitted (see discussion above). - - if Name (1) /= '_' then - Append_Info_String ("Exception name: ", Info, Ptr); - Append_Info_String (Name, Info, Ptr); - Append_Info_NL (Info, Ptr); - - if Msg_Len /= 0 then - Append_Info_String ("Message: ", Info, Ptr); - Append_Info_String (Msg, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end if; - - -- Output PID line if non-zero - - if X.Pid /= 0 then - Append_Info_String ("PID: ", Info, Ptr); - Append_Info_Nat (X.Pid, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - - return Info (1 .. Ptr); - end Basic_Exception_Information; - - ------------------------------- - -- Basic_Exception_Traceback -- - ------------------------------- - - function Basic_Exception_Traceback - (X : Exception_Occurrence) - return String - is - Info_Maxlen : constant Natural := 35 + X.Num_Tracebacks * 19; - -- Maximum length of the information string we are building, with : - -- 33 = 31 + 4 for the text before and after the traceback, and - -- 19 = 2 + 16 + 1 for each address ("0x" + HHHH + " ") - -- - -- WARNING : Do not forget to update these numbers if anything - -- involved in the computation changes. - - Info : String (1 .. Info_Maxlen); - -- Information string we are going to build, containing an image - -- of the call chain associated with the exception occurrence in its - -- most basic form, that is as a sequence of binary addresses. - - Ptr : Natural := 0; - - begin - if X.Num_Tracebacks > 0 then - Append_Info_String ("Call stack traceback locations:", Info, Ptr); - Append_Info_NL (Info, Ptr); - - for J in 1 .. X.Num_Tracebacks loop - Append_Info_String (Address_Image (X.Tracebacks (J)), Info, Ptr); - exit when J = X.Num_Tracebacks; - Append_Info_String (" ", Info, Ptr); - end loop; - - Append_Info_NL (Info, Ptr); - end if; - - return Info (1 .. Ptr); - end Basic_Exception_Traceback; - - ----------------- - -- Break_Start -- - ----------------- - - procedure Break_Start is - begin - null; - end Break_Start; - ---------------- -- Call_Chain -- ---------------- - procedure Call_Chain (Excep : EOA) is - begin - if Excep.Num_Tracebacks /= 0 then - -- This is a reraise, no need to store a new (wrong) chain. - return; - end if; - - System.Traceback.Call_Chain - (Excep.Tracebacks'Address, - Max_Tracebacks, - Excep.Num_Tracebacks, - AAA'Address, - ZZZ'Address); - end Call_Chain; + procedure Call_Chain (Excep : EOA) is separate; + -- The actual Call_Chain routine is separate, so that it can easily + -- be dummied out when no exception traceback information is needed. ------------------------------ -- Current_Target_Exception -- @@ -1105,14 +621,8 @@ package body Ada.Exceptions is -- EId_To_String -- ------------------- - function EId_To_String (X : Exception_Id) return String is - begin - if X = Null_Id then - return ""; - else - return Exception_Name (X); - end if; - end EId_To_String; + function EId_To_String (X : Exception_Id) return String + renames Stream_Attributes.EId_To_String; ------------------ -- EO_To_String -- @@ -1121,14 +631,8 @@ package body Ada.Exceptions is -- We use the null string to represent the null occurrence, otherwise -- we output the Exception_Information string for the occurrence. - function EO_To_String (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - return ""; - else - return Exception_Information (X); - end if; - end EO_To_String; + function EO_To_String (X : Exception_Occurrence) return String + renames Stream_Attributes.EO_To_String; ------------------------ -- Exception_Identity -- @@ -1150,63 +654,8 @@ package body Ada.Exceptions is -- Exception_Information -- --------------------------- - -- The format of the string is: - - -- Exception_Name: nnnnn - -- Message: mmmmm - -- PID: ppp - -- Call stack traceback locations: - -- 0xhhhh 0xhhhh 0xhhhh ... 0xhhh - - -- where - - -- nnnn is the fully qualified name of the exception in all upper - -- case letters. This line is always present. - - -- mmmm is the message (this line present only if message is non-null) - - -- ppp is the Process Id value as a decimal integer (this line is - -- present only if the Process Id is non-zero). Currently we are - -- not making use of this field. - - -- The Call stack traceback locations line and the following values - -- are present only if at least one traceback location was recorded. - -- the values are given in C style format, with lower case letters - -- for a-f, and only as many digits present as are necessary. - - -- The line terminator sequence at the end of each line, including the - -- last line is a CR-LF sequence (16#0D# followed by 16#0A#). - - -- The Exception_Name and Message lines are omitted in the abort - -- signal case, since this is not really an exception, and the only - -- use of this routine is internal for printing termination output. - - -- WARNING: if the format of the generated string is changed, please note - -- that an equivalent modification to the routine String_To_EO must be - -- made to preserve proper functioning of the stream attributes. - - function Exception_Information (X : Exception_Occurrence) return String is - - -- This information is now built using the circuitry introduced in - -- association with the support of traceback decorators, as the - -- catenation of the exception basic information and the call chain - -- backtrace in its basic form. - - Basic_Info : constant String := Basic_Exception_Information (X); - Tback_Info : constant String := Basic_Exception_Traceback (X); - - Basic_Len : constant Natural := Basic_Info'Length; - Tback_Len : constant Natural := Tback_Info'Length; - - Info : String (1 .. Basic_Len + Tback_Len); - Ptr : Natural := 0; - - begin - Append_Info_String (Basic_Info, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); - - return Info; - end Exception_Information; + function Exception_Information (X : Exception_Occurrence) return String + renames Exception_Data.Exception_Information; ----------------------- -- Exception_Message -- @@ -1257,6 +706,41 @@ package body Ada.Exceptions is return Name (P .. Name'Length); end Exception_Name_Simple; + -------------------- + -- Exception_Data -- + -------------------- + + package body Exception_Data is separate; + -- This package can be easily dummied out if we do not want the + -- basic support for exception messages (such as in Ada 83). + + --------------------------- + -- Exception_Propagation -- + --------------------------- + + package body Exception_Propagation is separate; + -- Depending on the actual exception mechanism used (front-end or + -- back-end based), the implementation will differ, which is why this + -- package is separated. + + ---------------------- + -- Exception_Traces -- + ---------------------- + + package body Exception_Traces is separate; + -- Depending on the underlying support for IO the implementation + -- will differ. Moreover we would like to dummy out this package + -- in case we do not want any exception tracing support. This is + -- why this package is separated. + + ----------------------- + -- Stream Attributes -- + ----------------------- + + package body Stream_Attributes is separate; + -- This package can be easily dummied out if we do not want the + -- support for streaming Exception_Ids and Exception_Occurrences. + ----------------------------- -- Process_Raise_Exception -- ----------------------------- @@ -1269,8 +753,6 @@ package body Ada.Exceptions is -- This is so the debugger can reliably inspect the parameter Jumpbuf_Ptr : constant Address := Get_Jmpbuf_Address.all; - Mstate_Ptr : constant Machine_State := - Machine_State (Get_Machine_State_Addr.all); Excep : EOA := Get_Current_Excep.all; begin @@ -1286,36 +768,38 @@ package body Ada.Exceptions is if Zero_Cost_Exceptions /= 0 then -- Use the front-end tables to propagate if we have them, otherwise - -- resort to the GCC back-end alternative. The backtrace for the - -- occurrence is stored while walking up the stack, and thus stops - -- in the handler's frame if there is one. Notifications are also - -- not performed here since it is not yet known if the exception is - -- handled. - - -- Set the machine state unless we are raising from a signal handler - -- since it has already been set properly in that case. - - if not From_Signal_Handler then - Set_Machine_State (Mstate_Ptr); - end if; + -- resort to the GCC back-end alternative. Backtrace computation is + -- performed, if required, by the underlying routine. Notifications + -- for the debugger are also not performed here, because we do not + -- yet know if the exception is handled. - if Subprogram_Descriptors /= null then - Propagate_Exception_With_FE_Support (Mstate_Ptr); - else - Propagate_Exception_With_GCC_Support (Mstate_Ptr); - end if; + Exception_Propagation.Propagate_Exception (From_Signal_Handler); else - -- Compute the backtrace for this occurrence if the corresponding - -- binder option has been set and we are not raising from a signal - -- handler. Call_Chain takes care of the reraise case. + -- binder option has been set. Call_Chain takes care of the reraise + -- case. - if not From_Signal_Handler - and then Exception_Tracebacks /= 0 - then - Call_Chain (Excep); - end if; + Call_Chain (Excep); + -- We used to only do this if From_Signal_Handler was not set, + -- based on the assumption that backtracing from a signal handler + -- would not work due to stack layout oddities. However, since + -- + -- 1. The flag is never set in tasking programs (Notify_Exception + -- performs regular raise statements), and + -- + -- 2. No problem has shown up in tasking programs around here so + -- far, this turned out to be too strong an assumption. + -- + -- As, in addition, the test was + -- + -- 1. preventing the production of backtraces in non-tasking + -- programs, and + -- + -- 2. introducing a behavior inconsistency between + -- the tasking and non-tasking cases, + -- + -- we have simply removed it. -- If the jump buffer pointer is non-null, transfer control using -- it. Otherwise announce an unhandled exception (note that this @@ -1326,306 +810,22 @@ package body Ada.Exceptions is if not Excep.Exception_Raised then Excep.Exception_Raised := True; - Notify_Handled_Exception (Null_Loc, False, False); - - -- The low level debugger notification is skipped from the - -- call above because we do not have the necessary information - -- to "feed" it properly. - + Exception_Traces.Notify_Handled_Exception; end if; builtin_longjmp (Jumpbuf_Ptr, 1); else - Notify_Unhandled_Exception (E); - Unhandled_Exception_Terminate; - end if; - end if; - - end Process_Raise_Exception; - - ----------------------------------------- - -- Propagate_Exception_With_FE_Support -- - ----------------------------------------- - - procedure Propagate_Exception_With_FE_Support (Mstate : Machine_State) is - Excep : constant EOA := Get_Current_Excep.all; - Loc : Code_Loc; - Lo, Hi : Natural; - Pdesc : Natural; - Hrec : Handler_Record_Ptr; - Info : Subprogram_Info_Type; - - type Machine_State_Record is - new Storage_Array (1 .. Machine_State_Length); - for Machine_State_Record'Alignment use Standard'Maximum_Alignment; - - procedure Duplicate_Machine_State (Dest, Src : Machine_State); - -- Copy Src into Dest, assuming that a Machine_State is pointing to - -- an area of Machine_State_Length bytes. - - procedure Duplicate_Machine_State (Dest, Src : Machine_State) is - type Machine_State_Record_Access is access Machine_State_Record; - function To_MSR is new Unchecked_Conversion - (Machine_State, Machine_State_Record_Access); - - begin - To_MSR (Dest).all := To_MSR (Src).all; - end Duplicate_Machine_State; - - -- Data for handling the finalization handler case. A simple approach - -- in this routine would simply to unwind stack frames till we find a - -- handler and then enter it. But this is undesirable in the case where - -- we have only finalization handlers, and no "real" handler, i.e. a - -- case where we have an unhandled exception. - - -- In this case we prefer to signal unhandled exception with the stack - -- intact, and entering finalization handlers would destroy the stack - -- state. To deal with this, as we unwind the stack, we note the first - -- finalization handler, and remember it in the following variables. - -- We then continue to unwind. If and when we find a "real", i.e. non- - -- finalization handler, then we use these variables to pass control to - -- the finalization handler. - - FH_Found : Boolean := False; - -- Set when a finalization handler is found - - FH_Mstate : aliased Machine_State_Record; - -- Records the machine state for the finalization handler - - FH_Handler : Code_Loc := Null_Address; - -- Record handler address for finalization handler - - FH_Num_Trb : Natural := 0; - -- Save number of tracebacks for finalization handler - - begin - -- Loop through stack frames as exception propagates - - Main_Loop : loop - Loc := Get_Code_Loc (Mstate); - exit Main_Loop when Loc = Null_Loc; - - -- Record location unless it is inside this unit. Note: this - -- test should really say Code_Address, but Address is the same - -- as Code_Address for unnested subprograms, and Code_Address - -- would cause a bootstrap problem - - if Loc < AAA'Address or else Loc > ZZZ'Address then + -- The pragma Inspection point here ensures that the debugger + -- can inspect the parameter. - -- Record location unless we already recorded max tracebacks + pragma Inspection_Point (E); - if Excep.Num_Tracebacks /= Max_Tracebacks then - - -- Do not record location if it is the return point from - -- a reraise call from within a cleanup handler - - if not Excep.Cleanup_Flag then - Excep.Num_Tracebacks := Excep.Num_Tracebacks + 1; - Excep.Tracebacks (Excep.Num_Tracebacks) := Loc; - - -- For reraise call from cleanup handler, skip entry and - -- clear the flag so that we will start to record again - - else - Excep.Cleanup_Flag := False; - end if; - end if; + Exception_Traces.Notify_Unhandled_Exception; + Exception_Traces.Unhandled_Exception_Terminate; end if; - - -- Do binary search on procedure table - - Lo := 1; - Hi := Num_Subprogram_Descriptors; - - -- Binary search loop - - loop - Pdesc := (Lo + Hi) / 2; - - -- Note that Loc is expected to be the procedure's call point - -- and not the return point. - - if Loc < Subprogram_Descriptors (Pdesc).Code then - Hi := Pdesc - 1; - - elsif Pdesc < Num_Subprogram_Descriptors - and then Loc > Subprogram_Descriptors (Pdesc + 1).Code - then - Lo := Pdesc + 1; - - else - exit; - end if; - - -- This happens when the current Loc is completely outside of - -- the range of the program, which usually means that we reached - -- the top level frame (e.g __start). In this case we have an - -- unhandled exception. - - exit Main_Loop when Hi < Lo; - end loop; - - -- Come here with Subprogram_Descriptors (Pdesc) referencing the - -- procedure descriptor that applies to this PC value. Now do a - -- serial search to see if any handler is applicable to this PC - -- value, and to the exception that we are propagating - - for J in 1 .. Subprogram_Descriptors (Pdesc).Num_Handlers loop - Hrec := Subprogram_Descriptors (Pdesc).Handler_Records (J); - - if Loc >= Hrec.Lo and then Loc < Hrec.Hi then - - -- PC range is applicable, see if handler is for this exception - - -- First test for case of "all others" (finalization) handler. - -- We do not enter such a handler until we are sure there is - -- a real handler further up the stack. - - if Hrec.Id = All_Others_Id then - - -- If this is the first finalization handler, then - -- save the machine state so we can enter it later - -- without having to repeat the search. - - if not FH_Found then - FH_Found := True; - Duplicate_Machine_State - (Machine_State (FH_Mstate'Address), Mstate); - FH_Handler := Hrec.Handler; - FH_Num_Trb := Excep.Num_Tracebacks; - end if; - - -- Normal (non-finalization exception with matching Id) - - elsif Excep.Id = Hrec.Id - or else (Hrec.Id = Others_Id - and not Excep.Id.Not_Handled_By_Others) - then - -- Perform the necessary notification tasks. - - Notify_Handled_Exception - (Hrec.Handler, Hrec.Id = Others_Id, True); - - -- If we already encountered a finalization handler, then - -- reset the context to that handler, and enter it. - - if FH_Found then - Excep.Num_Tracebacks := FH_Num_Trb; - Excep.Cleanup_Flag := True; - - Enter_Handler - (Machine_State (FH_Mstate'Address), FH_Handler); - - -- If we have not encountered a finalization handler, - -- then enter the current handler. - - else - Enter_Handler (Mstate, Hrec.Handler); - end if; - end if; - end if; - end loop; - - Info := Subprogram_Descriptors (Pdesc).Subprogram_Info; - exit Main_Loop when Info = No_Info; - Pop_Frame (Mstate, Info); - end loop Main_Loop; - - -- Fall through if no "real" exception handler found. First thing is to - -- perform the necessary notification tasks with the stack intact. - - Notify_Unhandled_Exception (Excep.Id); - - -- If there were finalization handlers, then enter the top one. - -- Just because there is no handler does not mean we don't have - -- to still execute all finalizations and cleanups before - -- terminating. Note that the process of calling cleanups - -- does not disturb the back trace stack, since he same - -- exception occurrence gets reraised, and new traceback - -- entries added as we go along. - - if FH_Found then - Excep.Num_Tracebacks := FH_Num_Trb; - Excep.Cleanup_Flag := True; - Enter_Handler (Machine_State (FH_Mstate'Address), FH_Handler); - end if; - - -- If no cleanups, then this is the real unhandled termination - - Unhandled_Exception_Terminate; - - end Propagate_Exception_With_FE_Support; - - ------------------------------------------ - -- Propagate_Exception_With_GCC_Support -- - ------------------------------------------ - - procedure Propagate_Exception_With_GCC_Support (Mstate : Machine_State) is - Excep : EOA := Get_Current_Excep.all; - This_Exception : aliased GNAT_GCC_Exception; - Status : Unwind_Reason_Code; - - begin - -- ??? Nothing is currently done for backtracing purposes. We could - -- have used the personality routine to record the addresses while - -- walking up the stack, but this method has two drawbacks : 1/ the - -- trace is incomplete if the exception is handled since we don't walk - -- up the frame with the handler, and 2/ we will miss frames if the - -- exception propagates through frames for which our personality - -- routine is not called (e.g. if C or C++ frames are on the way). - - -- Fill in the useful flags for the personality routine called for each - -- frame via the call to Unwind_RaiseException below. - - This_Exception.Id := Excep.Id; - This_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others; - This_Exception.Has_Cleanup := False; - - -- We are looking for a regular handler first. If there is one, either - -- it or the first at-end handler before it will be entered. If there - -- is none, control will normally get back to after the call, with - -- Has_Cleanup set to true if at least one at-end handler has been - -- found while walking up the stack. - - This_Exception.Select_Cleanups := False; - - Status := Unwind_RaiseException (This_Exception'Access); - - -- If we get here we know the exception is not handled, as otherwise - -- Unwind_RaiseException arranges for a handler to be entered. We might - -- have met cleanups handlers, though, requiring to start again with - -- the Select_Cleanups flag set to True. - - -- Before restarting for cleanups, take the necessary steps to enable - -- the debugger to gain control while the stack is still intact. Flag - -- the occurrence as raised to avoid notifying again in case cleanup - -- handlers are entered later. - - if not Excep.Exception_Raised then - Excep.Exception_Raised := True; - Notify_Unhandled_Exception (Excep.Id); - end if; - - -- Now raise again selecting cleanups as true handlers. Only do this if - -- we know at least one such handler exists since otherwise we would - -- perform a complete stack upwalk for nothing. - - if This_Exception.Has_Cleanup then - This_Exception.Select_Cleanups := True; - Status := Unwind_RaiseException (This_Exception'Access); - - -- The first cleanup found is entered. It performs its job, raises - -- the initial exception again, and the flow goes back to the first - -- step above with the stack in a different state. end if; - - -- We get here when there is no handler to be run at all. The debugger - -- has been notified before the second step above. - - Unhandled_Exception_Terminate; - - end Propagate_Exception_With_GCC_Support; + end Process_Raise_Exception; ---------------------------- -- Raise_Constraint_Error -- @@ -1636,7 +836,8 @@ package body Ada.Exceptions is Line : Integer) is begin - Raise_With_Location (Constraint_Error_Def'Access, File, Line); + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line); end Raise_Constraint_Error; -------------------------------- @@ -1670,15 +871,11 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - Excep : constant EOA := Get_Current_Excep.all; - begin if E /= null then - Excep.Msg_Length := Len; - Excep.Msg (1 .. Len) := Message (1 .. Len); - Raise_With_Msg (E); + Exception_Data.Set_Exception_Msg (E, Message); + Abort_Defer.all; + Raise_Current_Excep (E); end if; end Raise_Exception; @@ -1690,15 +887,10 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - - Excep : constant EOA := Get_Current_Excep.all; - begin - Excep.Msg_Length := Len; - Excep.Msg (1 .. Len) := Message (1 .. Len); - Raise_With_Msg (E); + Exception_Data.Set_Exception_Msg (E, Message); + Abort_Defer.all; + Raise_Current_Excep (E); end Raise_Exception_Always; ------------------------------- @@ -1710,23 +902,11 @@ package body Ada.Exceptions is M : Big_String_Ptr) is begin - Set_Exception_C_Msg (E, M); + Exception_Data.Set_Exception_C_Msg (E, M); Abort_Defer.all; Process_Raise_Exception (E => E, From_Signal_Handler => True); end Raise_From_Signal_Handler; - ------------------ - -- Raise_No_Msg -- - ------------------ - - procedure Raise_No_Msg (E : Exception_Id) is - Excep : constant EOA := Get_Current_Excep.all; - - begin - Excep.Msg_Length := 0; - Raise_With_Msg (E); - end Raise_No_Msg; - ------------------------- -- Raise_Program_Error -- ------------------------- @@ -1736,7 +916,8 @@ package body Ada.Exceptions is Line : Integer) is begin - Raise_With_Location (Program_Error_Def'Access, File, Line); + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line); end Raise_Program_Error; ----------------------------- @@ -1762,7 +943,8 @@ package body Ada.Exceptions is Line : Integer) is begin - Raise_With_Location (Storage_Error_Def'Access, File, Line); + Raise_With_Location_And_Msg + (Storage_Error_Def'Access, File, Line); end Raise_Storage_Error; ----------------------------- @@ -1779,35 +961,6 @@ package body Ada.Exceptions is (Storage_Error_Def'Access, File, Line, Msg); end Raise_Storage_Error_Msg; - ---------------------- - -- Raise_With_C_Msg -- - ---------------------- - - procedure Raise_With_C_Msg - (E : Exception_Id; - M : Big_String_Ptr) - is - begin - Set_Exception_C_Msg (E, M); - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_C_Msg; - - ------------------------- - -- Raise_With_Location -- - ------------------------- - - procedure Raise_With_Location - (E : Exception_Id; - F : Big_String_Ptr; - L : Integer) - is - begin - Set_Exception_C_Msg (E, F, L); - Abort_Defer.all; - Raise_Current_Excep (E); - end Raise_With_Location; - --------------------------------- -- Raise_With_Location_And_Msg -- --------------------------------- @@ -1816,10 +969,10 @@ package body Ada.Exceptions is (E : Exception_Id; F : Big_String_Ptr; L : Integer; - M : Big_String_Ptr) + M : Big_String_Ptr := null) is begin - Set_Exception_C_Msg (E, F, L, M); + Exception_Data.Set_Exception_C_Msg (E, F, L, M); Abort_Defer.all; Raise_Current_Excep (E); end Raise_With_Location_And_Msg; @@ -1828,10 +981,14 @@ package body Ada.Exceptions is -- Raise_With_Msg -- -------------------- - procedure Raise_With_Msg (E : Exception_Id) is + procedure Raise_With_Msg (E : Exception_Id; Setup : Boolean) is Excep : constant EOA := Get_Current_Excep.all; begin + if not Setup then + Exception_Propagation.Setup_Exception (Excep, Excep); + end if; + Excep.Exception_Raised := False; Excep.Id := E; Excep.Num_Tracebacks := 0; @@ -1841,6 +998,169 @@ package body Ada.Exceptions is Raise_Current_Excep (E); end Raise_With_Msg; + procedure Raise_With_Msg (E : Exception_Id) is + begin + Raise_With_Msg (E, Setup => False); + end Raise_With_Msg; + + ----------------------- + -- Raise_After_Setup -- + ----------------------- + + procedure Raise_After_Setup (E : Exception_Id) is + begin + Raise_With_Msg (E, Setup => True); + end Raise_After_Setup; + + -------------------------------------- + -- Calls to Run-Time Check Routines -- + -------------------------------------- + + procedure Rcheck_00 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_00'Address)); + end Rcheck_00; + + procedure Rcheck_01 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_01'Address)); + end Rcheck_01; + + procedure Rcheck_02 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_02'Address)); + end Rcheck_02; + + procedure Rcheck_03 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_03'Address)); + end Rcheck_03; + + procedure Rcheck_04 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_04'Address)); + end Rcheck_04; + + procedure Rcheck_05 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_05'Address)); + end Rcheck_05; + + procedure Rcheck_06 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_06'Address)); + end Rcheck_06; + + procedure Rcheck_07 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_07'Address)); + end Rcheck_07; + + procedure Rcheck_08 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_08'Address)); + end Rcheck_08; + + procedure Rcheck_09 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_09'Address)); + end Rcheck_09; + + procedure Rcheck_10 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_10'Address)); + end Rcheck_10; + + procedure Rcheck_11 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Constraint_Error_Msg (File, Line, To_Ptr (Rmsg_11'Address)); + end Rcheck_11; + + procedure Rcheck_12 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_12'Address)); + end Rcheck_12; + + procedure Rcheck_13 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_13'Address)); + end Rcheck_13; + + procedure Rcheck_14 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_14'Address)); + end Rcheck_14; + + procedure Rcheck_15 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_15'Address)); + end Rcheck_15; + + procedure Rcheck_16 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_16'Address)); + end Rcheck_16; + + procedure Rcheck_17 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_17'Address)); + end Rcheck_17; + + procedure Rcheck_18 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_18'Address)); + end Rcheck_18; + + procedure Rcheck_19 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_19'Address)); + end Rcheck_19; + + procedure Rcheck_20 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_20'Address)); + end Rcheck_20; + + procedure Rcheck_21 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_21'Address)); + end Rcheck_21; + + procedure Rcheck_22 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_22'Address)); + end Rcheck_22; + + procedure Rcheck_23 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Program_Error_Msg (File, Line, To_Ptr (Rmsg_23'Address)); + end Rcheck_23; + + procedure Rcheck_24 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_24'Address)); + end Rcheck_24; + + procedure Rcheck_25 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_25'Address)); + end Rcheck_25; + + procedure Rcheck_26 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_26'Address)); + end Rcheck_26; + + procedure Rcheck_27 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_27'Address)); + end Rcheck_27; + + procedure Rcheck_28 (File : Big_String_Ptr; Line : Integer) is + begin + Raise_Storage_Error_Msg (File, Line, To_Ptr (Rmsg_28'Address)); + end Rcheck_28; + ------------- -- Reraise -- ------------- @@ -1850,6 +1170,7 @@ package body Ada.Exceptions is begin Abort_Defer.all; + Exception_Propagation.Setup_Exception (Excep, Excep, Reraised => True); Raise_Current_Excep (Excep.Id); end Reraise; @@ -1861,7 +1182,9 @@ package body Ada.Exceptions is begin if X.Id /= null then Abort_Defer.all; - Save_Occurrence (Get_Current_Excep.all.all, X); + Exception_Propagation.Setup_Exception + (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end if; end Reraise_Occurrence; @@ -1873,7 +1196,9 @@ package body Ada.Exceptions is procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is begin Abort_Defer.all; - Save_Occurrence (Get_Current_Excep.all.all, X); + Exception_Propagation.Setup_Exception + (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_Always; @@ -1883,7 +1208,9 @@ package body Ada.Exceptions is procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is begin - Save_Occurrence (Get_Current_Excep.all.all, X); + Exception_Propagation.Setup_Exception + (X'Unrestricted_Access, Get_Current_Excep.all, Reraised => True); + Save_Occurrence_No_Private (Get_Current_Excep.all.all, X); Raise_Current_Excep (X.Id); end Reraise_Occurrence_No_Defer; @@ -1896,17 +1223,7 @@ package body Ada.Exceptions is Source : Exception_Occurrence) is begin - Target.Id := Source.Id; - Target.Msg_Length := Source.Msg_Length; - Target.Num_Tracebacks := Source.Num_Tracebacks; - Target.Pid := Source.Pid; - Target.Cleanup_Flag := Source.Cleanup_Flag; - - Target.Msg (1 .. Target.Msg_Length) := - Source.Msg (1 .. Target.Msg_Length); - - Target.Tracebacks (1 .. Target.Num_Tracebacks) := - Source.Tracebacks (1 .. Target.Num_Tracebacks); + Save_Occurrence_No_Private (Target, Source); end Save_Occurrence; function Save_Occurrence @@ -1920,629 +1237,73 @@ package body Ada.Exceptions is return Target; end Save_Occurrence; - --------------------- - -- SDP_Table_Build -- - --------------------- + -------------------------------- + -- Save_Occurrence_And_Private -- + -------------------------------- - procedure SDP_Table_Build - (SDP_Addresses : System.Address; - SDP_Count : Natural; - Elab_Addresses : System.Address; - Elab_Addr_Count : Natural) + procedure Save_Occurrence_And_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) is - type SDLP_Array is array (1 .. SDP_Count) of Subprogram_Descriptors_Ptr; - type SDLP_Array_Ptr is access all SDLP_Array; - - function To_SDLP_Array_Ptr is new Unchecked_Conversion - (System.Address, SDLP_Array_Ptr); - - T : constant SDLP_Array_Ptr := To_SDLP_Array_Ptr (SDP_Addresses); - - type Elab_Array is array (1 .. Elab_Addr_Count) of Code_Loc; - type Elab_Array_Ptr is access all Elab_Array; - - function To_Elab_Array_Ptr is new Unchecked_Conversion - (System.Address, Elab_Array_Ptr); - - EA : constant Elab_Array_Ptr := To_Elab_Array_Ptr (Elab_Addresses); - - Ndes : Natural; - Previous_Subprogram_Descriptors : Subprogram_Descriptor_List_Ptr; - begin - -- If first call, then initialize count of subprogram descriptors - - if Subprogram_Descriptors = null then - Num_Subprogram_Descriptors := 0; - end if; - - -- First count number of subprogram descriptors. This count includes - -- entries with duplicated code addresses (resulting from Import). - - Ndes := Num_Subprogram_Descriptors + Elab_Addr_Count; - for J in T'Range loop - Ndes := Ndes + T (J).Count; - end loop; - - -- Now, allocate the new table (extra zero'th element is for sort call) - -- after having saved the previous one - - Previous_Subprogram_Descriptors := Subprogram_Descriptors; - Subprogram_Descriptors := new Subprogram_Descriptor_List (0 .. Ndes); - - -- If there was a previous Subprogram_Descriptors table, copy it back - -- into the new one being built. Then free the memory used for the - -- previous table. - - for J in 1 .. Num_Subprogram_Descriptors loop - Subprogram_Descriptors (J) := Previous_Subprogram_Descriptors (J); - end loop; - - Free (Previous_Subprogram_Descriptors); - - -- Next, append the elaboration routine addresses, building dummy - -- SDP's for them as we go through the list. - - Ndes := Num_Subprogram_Descriptors; - for J in EA'Range loop - Ndes := Ndes + 1; - Subprogram_Descriptors (Ndes) := new Subprogram_Descriptor_0; - - Subprogram_Descriptors (Ndes).all := - Subprogram_Descriptor' - (Num_Handlers => 0, - Code => Fetch_Code (EA (J)), - Subprogram_Info => EA (J), - Handler_Records => (1 .. 0 => null)); - end loop; - - -- Now copy in pointers to SDP addresses of application subprograms - - for J in T'Range loop - for K in 1 .. T (J).Count loop - Ndes := Ndes + 1; - Subprogram_Descriptors (Ndes) := T (J).SDesc (K); - Subprogram_Descriptors (Ndes).Code := - Fetch_Code (T (J).SDesc (K).Code); - end loop; - end loop; - - -- Now we need to sort the table into ascending PC order - - Sort (Ndes, SDP_Table_Sort_Move'Access, SDP_Table_Sort_Lt'Access); - - -- Now eliminate duplicate entries. Note that in the case where - -- entries have duplicate code addresses, the code for the Lt - -- routine ensures that the interesting one (i.e. the one with - -- handler entries if there are any) comes first. + Save_Occurrence_No_Private (Target, Source); + Target.Private_Data := Source.Private_Data; + end Save_Occurrence_And_Private; - Num_Subprogram_Descriptors := 1; - - for J in 2 .. Ndes loop - if Subprogram_Descriptors (J).Code /= - Subprogram_Descriptors (Num_Subprogram_Descriptors).Code - then - Num_Subprogram_Descriptors := Num_Subprogram_Descriptors + 1; - Subprogram_Descriptors (Num_Subprogram_Descriptors) := - Subprogram_Descriptors (J); - end if; - end loop; - - end SDP_Table_Build; - - ----------------------- - -- SDP_Table_Sort_Lt -- - ----------------------- - - function SDP_Table_Sort_Lt (Op1, Op2 : Natural) return Boolean is - SDC1 : constant Code_Loc := Subprogram_Descriptors (Op1).Code; - SDC2 : constant Code_Loc := Subprogram_Descriptors (Op2).Code; + -------------------------------- + -- Save_Occurrence_No_Private -- + -------------------------------- + procedure Save_Occurrence_No_Private + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is begin - if SDC1 < SDC2 then - return True; - - elsif SDC1 > SDC2 then - return False; - - -- For two descriptors for the same procedure, we want the more - -- interesting one first. A descriptor with an exception handler - -- is more interesting than one without. This happens if the less - -- interesting one came from a pragma Import. - - else - return Subprogram_Descriptors (Op1).Num_Handlers /= 0 - and then Subprogram_Descriptors (Op2).Num_Handlers = 0; - end if; - end SDP_Table_Sort_Lt; + Target.Id := Source.Id; + Target.Msg_Length := Source.Msg_Length; + Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Pid := Source.Pid; + Target.Cleanup_Flag := Source.Cleanup_Flag; - -------------------------- - -- SDP_Table_Sort_Move -- - -------------------------- + Target.Msg (1 .. Target.Msg_Length) := + Source.Msg (1 .. Target.Msg_Length); - procedure SDP_Table_Sort_Move (From : Natural; To : Natural) is - begin - Subprogram_Descriptors (To) := Subprogram_Descriptors (From); - end SDP_Table_Sort_Move; + Target.Tracebacks (1 .. Target.Num_Tracebacks) := + Source.Tracebacks (1 .. Target.Num_Tracebacks); + end Save_Occurrence_No_Private; ------------------------- - -- Set_Exception_C_Msg -- + -- Transfer_Occurrence -- ------------------------- - procedure Set_Exception_C_Msg - (Id : Exception_Id; - Msg1 : Big_String_Ptr; - Line : Integer := 0; - Msg2 : Big_String_Ptr := null) + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence) is - Excep : constant EOA := Get_Current_Excep.all; - Val : Integer := Line; - Remind : Integer; - Size : Integer := 1; - Ptr : Natural; - begin - Excep.Exception_Raised := False; - Excep.Id := Id; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - Excep.Msg_Length := 0; - Excep.Cleanup_Flag := False; - - while Msg1 (Excep.Msg_Length + 1) /= ASCII.NUL - and then Excep.Msg_Length < Exception_Msg_Max_Length - loop - Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := Msg1 (Excep.Msg_Length); - end loop; - - -- Append line number if present - - if Line > 0 then - - -- Compute the number of needed characters + -- Setup Target as an exception to be propagated in the calling task + -- (rendezvous-wise), taking care not to clobber the associated private + -- data. Target is expected to be a pointer to the calling task's + -- fixed TSD occurrence, which is very different from Get_Current_Excep + -- here because this subprogram is called from the called task. - while Val > 0 loop - Val := Val / 10; - Size := Size + 1; - end loop; - - -- If enough characters are available, put the line number - - if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then - Excep.Msg (Excep.Msg_Length + 1) := ':'; - Excep.Msg_Length := Excep.Msg_Length + Size; - Val := Line; - Size := 0; - - while Val > 0 loop - Remind := Val rem 10; - Val := Val / 10; - Excep.Msg (Excep.Msg_Length - Size) := - Character'Val (Remind + Character'Pos ('0')); - Size := Size + 1; - end loop; - end if; - end if; - - -- Append second message if present - - if Msg2 /= null - and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length - then - Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := ' '; - - Ptr := 1; - while Msg2 (Ptr) /= ASCII.NUL - and then Excep.Msg_Length < Exception_Msg_Max_Length - loop - Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := Msg2 (Ptr); - Ptr := Ptr + 1; - end loop; - end if; - end Set_Exception_C_Msg; + Exception_Propagation.Setup_Exception (Target, Target); + Save_Occurrence_No_Private (Target.all, Source); + end Transfer_Occurrence; ------------------- -- String_To_EId -- ------------------- - function String_To_EId (S : String) return Exception_Id is - begin - if S = "" then - return Null_Id; - else - return Exception_Id (Internal_Exception (S)); - end if; - end String_To_EId; + function String_To_EId (S : String) return Exception_Id + renames Stream_Attributes.String_To_EId; ------------------ -- String_To_EO -- ------------------ - function String_To_EO (S : String) return Exception_Occurrence is - From : Natural; - To : Integer; - - X : Exception_Occurrence; - -- This is the exception occurrence we will create - - procedure Bad_EO; - pragma No_Return (Bad_EO); - -- Signal bad exception occurrence string - - procedure Next_String; - -- On entry, To points to last character of previous line of the - -- message, terminated by LF. On return, From .. To are set to - -- specify the next string, or From > To if there are no more lines. - - procedure Bad_EO is - begin - Raise_Exception - (Program_Error'Identity, - "bad exception occurrence in stream input"); - end Bad_EO; - - procedure Next_String is - begin - From := To + 2; - - if From < S'Last then - To := From + 1; - - while To < S'Last - 1 loop - if To >= S'Last then - Bad_EO; - elsif S (To + 1) = ASCII.LF then - exit; - else - To := To + 1; - end if; - end loop; - end if; - end Next_String; - - -- Start of processing for String_To_EO - - begin - if S = "" then - return Null_Occurrence; - - else - X.Cleanup_Flag := False; - - To := S'First - 2; - Next_String; - - if S (From .. From + 15) /= "Exception name: " then - Bad_EO; - end if; - - X.Id := Exception_Id (Internal_Exception (S (From + 16 .. To))); - - Next_String; - - if From <= To and then S (From) = 'M' then - if S (From .. From + 8) /= "Message: " then - Bad_EO; - end if; - - X.Msg_Length := To - From - 8; - X.Msg (1 .. X.Msg_Length) := S (From + 9 .. To); - Next_String; - - else - X.Msg_Length := 0; - end if; - - X.Pid := 0; - - if From <= To and then S (From) = 'P' then - if S (From .. From + 3) /= "PID:" then - Bad_EO; - end if; - - From := From + 5; -- skip past PID: space - - while From <= To loop - X.Pid := X.Pid * 10 + - (Character'Pos (S (From)) - Character'Pos ('0')); - From := From + 1; - end loop; - - Next_String; - end if; - - X.Num_Tracebacks := 0; - - if From <= To then - if S (From .. To) /= "Call stack traceback locations:" then - Bad_EO; - end if; - - Next_String; - loop - exit when From > To; - - declare - Ch : Character; - C : Integer_Address; - N : Integer_Address; - - begin - if S (From) /= '0' - or else S (From + 1) /= 'x' - then - Bad_EO; - else - From := From + 2; - end if; - - C := 0; - while From <= To loop - Ch := S (From); - - if Ch in '0' .. '9' then - N := - Character'Pos (S (From)) - Character'Pos ('0'); - - elsif Ch in 'a' .. 'f' then - N := - Character'Pos (S (From)) - Character'Pos ('a') + 10; - - elsif Ch = ' ' then - From := From + 1; - exit; - - else - Bad_EO; - end if; - - C := C * 16 + N; - - From := From + 1; - end loop; - - if X.Num_Tracebacks = Max_Tracebacks then - Bad_EO; - end if; - - X.Num_Tracebacks := X.Num_Tracebacks + 1; - X.Tracebacks (X.Num_Tracebacks) := To_Address (C); - end; - end loop; - end if; - - -- If an exception was converted to a string, it must have - -- already been raised, so flag it accordingly and we are done. - - X.Exception_Raised := True; - return X; - end if; - end String_To_EO; - - ---------------------------------- - -- Tailored_Exception_Traceback -- - ---------------------------------- - - function Tailored_Exception_Traceback - (X : Exception_Occurrence) - return String - is - -- We indeed reference the decorator *wrapper* from here and not the - -- decorator itself. The purpose of the local variable Wrapper is to - -- prevent a potential crash by race condition in the code below. The - -- atomicity of this assignment is enforced by pragma Atomic in - -- System.Soft_Links. - - -- The potential race condition here, if no local variable was used, - -- relates to the test upon the wrapper's value and the call, which - -- are not performed atomically. With the local variable, potential - -- changes of the wrapper's global value between the test and the - -- call become inoffensive. - - Wrapper : constant Traceback_Decorator_Wrapper_Call := - Traceback_Decorator_Wrapper; - - begin - if Wrapper = null then - return Basic_Exception_Traceback (X); - else - return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); - end if; - end Tailored_Exception_Traceback; - - ------------------------------------ - -- Tailored_Exception_Information -- - ------------------------------------ - - function Tailored_Exception_Information - (X : Exception_Occurrence) - return String - is - -- The tailored exception information is simply the basic information - -- associated with the tailored call chain backtrace. - - Basic_Info : constant String := Basic_Exception_Information (X); - Tback_Info : constant String := Tailored_Exception_Traceback (X); - - Basic_Len : constant Natural := Basic_Info'Length; - Tback_Len : constant Natural := Tback_Info'Length; - - Info : String (1 .. Basic_Len + Tback_Len); - Ptr : Natural := 0; - - begin - Append_Info_String (Basic_Info, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); - - return Info; - end Tailored_Exception_Information; - - ------------------------- - -- Unhandled_Exception -- - ------------------------- - - procedure Unhandled_Exception is - begin - null; - end Unhandled_Exception; - - ---------------------- - -- Notify_Exception -- - ---------------------- - - procedure Notify_Exception - (Id : Exception_Id; - Handler : Code_Loc; - Is_Others : Boolean) - is - begin - null; - end Notify_Exception; - - ------------------------------ - -- Notify_Handled_Exception -- - ------------------------------ - - procedure Notify_Handled_Exception - (Handler : Code_Loc; - Is_Others : Boolean; - Low_Notify : Boolean) - is - Excep : constant EOA := Get_Current_Excep.all; - - begin - -- Notify the debugger that we have found a handler and are about to - -- propagate an exception, but only if specifically told to do so. - - if Low_Notify then - Notify_Exception (Excep.Id, Handler, Is_Others); - end if; - - -- Output some exception information if necessary, as specified by - -- GNAT.Exception_Traces. Take care not to output information about - -- internal exceptions. - -- - -- ??? In the ZCX case, the traceback entries we have at this point - -- only include the ones we stored while walking up the stack *up to - -- the handler*. All the frames above the subprogram in which the - -- handler is found are missing. - - if Exception_Trace = Every_Raise - and then not Excep.Id.Not_Handled_By_Others - then - To_Stderr (Nline); - To_Stderr ("Exception raised"); - To_Stderr (Nline); - To_Stderr (Tailored_Exception_Information (Excep.all)); - end if; - - end Notify_Handled_Exception; - - ------------------------------ - -- Notify_Handled_Exception -- - ------------------------------ - - procedure Notify_Unhandled_Exception (Id : Exception_Id) is - begin - -- Simply perform the two necessary low level notification calls. - - Unhandled_Exception; - Notify_Exception (Id, Null_Loc, False); - - end Notify_Unhandled_Exception; - - ----------------------------------- - -- Unhandled_Exception_Terminate -- - ----------------------------------- - - adafinal_Called : Boolean := False; - -- Used to prevent recursive call to adafinal in the event that - -- adafinal processing itself raises an unhandled exception. - - type FILEs is new System.Address; - type int is new Integer; - - procedure Unhandled_Exception_Terminate is - - Excep : constant EOA := Save_Occurrence (Get_Current_Excep.all.all); - -- This occurrence will be used to display a message after finalization. - -- It is necessary to save a copy here, or else the designated value - -- could be overwritten if an exception is raised during finalization - -- (even if that exception is caught). - - Msg : constant String := Exception_Message (Excep.all); - - -- Start of processing for Unhandled_Exception_Terminate - - begin - -- First call adafinal - - if not adafinal_Called then - adafinal_Called := True; - System.Soft_Links.Adafinal.all; - end if; - - -- Check for special case of raising _ABORT_SIGNAL, which is not - -- really an exception at all. We recognize this by the fact that - -- it is the only exception whose name starts with underscore. - - if Exception_Name (Excep.all) (1) = '_' then - To_Stderr (Nline); - To_Stderr ("Execution terminated by abort of environment task"); - To_Stderr (Nline); - - -- If no tracebacks, we print the unhandled exception in the old style - -- (i.e. the style used before ZCX was implemented). We do this to - -- retain compatibility, especially with the nightly scripts, but - -- this can be removed at some point ??? - - elsif Excep.Num_Tracebacks = 0 then - To_Stderr (Nline); - To_Stderr ("raised "); - To_Stderr (Exception_Name (Excep.all)); - - if Msg'Length /= 0 then - To_Stderr (" : "); - To_Stderr (Msg); - end if; - - To_Stderr (Nline); - - -- New style, zero cost exception case - - else - -- Tailored_Exception_Information is also called here so that the - -- backtrace decorator gets called if it has been set. This is - -- currently required because some paths in Raise_Current_Excep - -- do not go through the calls that display this information. - -- - -- Note also that with the current scheme in Raise_Current_Excep - -- we can have this whole information output twice, typically when - -- some handler is found on the call chain but none deals with the - -- occurrence or if this occurrence gets reraised up to here. - - To_Stderr (Nline); - To_Stderr ("Execution terminated by unhandled exception"); - To_Stderr (Nline); - To_Stderr (Tailored_Exception_Information (Excep.all)); - end if; - - -- Perform system dependent shutdown code - - declare - procedure Unhandled_Terminate; - pragma No_Return (Unhandled_Terminate); - pragma Import - (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - - begin - Unhandled_Terminate; - end; - - end Unhandled_Exception_Terminate; + function String_To_EO (S : String) return Exception_Occurrence + renames Stream_Attributes.String_To_EO; ------------------------------ -- Raise_Exception_No_Defer -- @@ -2552,41 +1313,15 @@ package body Ada.Exceptions is (E : Exception_Id; Message : String := "") is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - - Excep : constant EOA := Get_Current_Excep.all; - begin - Excep.Exception_Raised := False; - Excep.Msg_Length := Len; - Excep.Msg (1 .. Len) := Message (1 .. Len); - Excep.Id := E; - Excep.Num_Tracebacks := 0; - Excep.Cleanup_Flag := False; - Excep.Pid := Local_Partition_ID; + Exception_Data.Set_Exception_Msg (E, Message); -- DO NOT CALL Abort_Defer.all; !!!! + -- why not??? would be nice to have more comments here Raise_Current_Excep (E); end Raise_Exception_No_Defer; - --------------- - -- To_Stderr -- - --------------- - - procedure To_Stderr (S : String) is - procedure put_char_stderr (C : int); - pragma Import (C, put_char_stderr, "put_char_stderr"); - - begin - for J in 1 .. S'Length loop - if S (J) /= ASCII.CR then - put_char_stderr (Character'Pos (S (J))); - end if; - end loop; - end To_Stderr; - --------- -- ZZZ -- --------- @@ -2597,11 +1332,18 @@ package body Ada.Exceptions is procedure ZZZ is begin - null; + <<Start_Of_ZZZ>> + Code_Address_For_ZZZ := Start_Of_ZZZ'Address; end ZZZ; begin -- Allocate the Non-Tasking Machine_State Set_Machine_State_Addr_NT (System.Address (Allocate_Machine_State)); + + -- Call the AAA/ZZZ routines to setup the code addresses for the + -- bounds of this unit. + + AAA; + ZZZ; end Ada.Exceptions; |